void dmEuclid2(double *learn, double *valid, int *learnF, int *validF, int *n, int *m, int *p, int *p2, double *dm, int *cl, int *k, double *mink, double *weights, double *weights2){
int i, j, l, l2, t, nn, ii, kk;
double tmp, *dvec, maxD, tmp2;
int *cvec;
kk = MAX(10L, *k);
kk = MIN(kk, *n);
nn = MIN(2L*kk, *n);
cvec = (int *) R_alloc(nn, sizeof(int));
dvec = (double *) R_alloc(nn, sizeof(double));
for(t=0;t<nn;t++)dvec[t]= BIG;
for(j=0;j<(*m);j++){
i=0L;
ii=0L;
maxD = BIG;
while(i<*n){
tmp=0.0;
l=0;
l2=0;
while(l<*p && tmp < (maxD+EPS)){
tmp2 = learn[i+l*n[0]]-valid[j+l*m[0]];
tmp += (tmp2*tmp2)* weights[l];
l++;
}
while(l2<*p2 && tmp < (maxD+EPS)){
if(learnF[i+l2*n[0]] != validF[j+l2*m[0]]) tmp += weights2[l2];
l2++;
}
if(tmp < maxD){
dvec[ii]=tmp;
cvec[ii]=i;
ii++;
}
if( ii==(nn-1L) ){
rsort_with_index(dvec, cvec, nn);
ii= *k-1L; // raus??
maxD = dvec[*k-1L];
}
i++;
}
rsort_with_index(dvec, cvec, nn);
for(t=0;t<*k;t++){
cl[j+t * *m]=cvec[t];
dm[j+t * *m]=sqrt(dvec[t]);
}
}
}
/* return all maxima in the array, modulo numeric tolerance. */
int all_max(double *array, int length, int *maxima, int *indexes,
double *buf) {
int i = 0, nmax = 0;
double tol = MACHINE_TOL;
/* make a safety copy of the array. */
memcpy(buf, array, length * sizeof(double));
/* sort the elements of the array. */
rsort_with_index(buf, indexes, length);
/* count the number of maxima (considering numeric tolerance). */
for (i = length - 1; i >= 0; i--)
if (buf[i] < buf[length - 1] - tol)
break;
/* set the counter for the number of maxima. */
nmax = length - i - 1;
/* save the indexes of the maxima. */
memcpy(maxima, indexes + length - nmax, nmax * sizeof(int));
return nmax;
}/*ALL_MAX*/
int MinSpanTree(int *tree, int nNodes, int nEdges, int *edges, double *costs, int node_index_from)
{
int *index = (int *) C_allocVector<int>(nEdges);
for (int i = 0; i < nEdges; i++)
{
tree[i] = 0;
index[i] = i;
}
rsort_with_index(costs, index, nEdges);
int *label = (int *) C_allocVector<int>(nNodes);
for (int i = 0; i < nNodes; i++)
label[i] = i;
int n = 0, n1, n2;
for (int i = 0; i < nEdges; i++)
{
n1 = label[edges[index[i]] - node_index_from];
n2 = label[edges[index[i] + nEdges] - node_index_from];
if (n1 != n2)
{
for (int j = 0; j < nNodes; j++)
if (label[j] == n2)
label[j] = n1;
tree[index[i]] = 1;
if (++n >= nNodes - 1)
break;
}
}
C_freeVector(index);
C_freeVector(label);
return n;
}
void dm(double *learn, double *valid, int *n, int *m, int *p, double *dm, int *cl, int *k, double *mink, double *weights){
int i, j, l, t, nn, ii, kk;
double tmp, *dvec, maxD;
int *cvec;
kk = MAX(10L, *k);
kk = MIN(kk, *n);
nn = MIN(2L*kk, *n);
cvec = (int *) R_alloc(nn, sizeof(int));
dvec = (double *) R_alloc(nn, sizeof(double));
for(t=0;t<nn;t++)dvec[t]= BIG;
for(j=0;j<(*m);j++){
i=0;
ii=0L;
maxD = BIG;
while(i<*n){
tmp=0.0;
l=0;
while(l<*p && tmp < (maxD+EPS)){
tmp+=pow(fabs(learn[i+l*n[0]]-valid[j+l*m[0]]),*mink)* weights[l];
l++;
}
if(tmp < maxD){
dvec[ii]=tmp;
cvec[ii]=i;
ii++;
}
if( ii==(nn-1L) ){
rsort_with_index(dvec, cvec, nn);
ii= *k-1L;
maxD = dvec[*k-1L];
}
i++;
}
rsort_with_index(dvec, cvec, nn);
for(t=0;t<*k;t++){
cl[j+t * *m]=cvec[t];
dm[j+t * *m]=pow(dvec[t],(1.0/(*mink)));
}
}
}
/* rectangular
* variant 2: fixed bandwidth, k nearest neighbors only
*/
void rectangular2 (double *weights, double *dist, int N, double *bw, int k) {
int i;
int index[N];
for (i = 0; i < N; i++) {
index[i] = i;
//Rprintf("index %u\n", index[i]);
}
rsort_with_index (dist, index, N);
/*for (i = 0; i < N; i++) {
Rprintf("dist0 %f\n", dist[i]);
Rprintf("index0 %u\n", index[i]);
}*/
for (i = 0; i < k; i++) {
weights[index[i]] = fabs(dist[i]) < *bw ? 0.5/ *bw : 0;
}
}
/* optcosine
* variant 2: fixed bandwidth, k nearest neighbors only
*/
void optcosine2 (double *weights, double *dist, int N, double *bw, int k) {
int i;
int index[N];
for (i = 0; i < N; i++) {
index[i] = i;
//Rprintf("index %u\n", index[i]);
}
rsort_with_index (dist, index, N);
/*for (i = 0; i < N; i++) {
Rprintf("dist0 %f\n", dist[i]);
Rprintf("index0 %u\n", index[i]);
}*/
for (i = 0; i < k; i++) {
weights[index[i]] = fabs(dist[i]) < *bw ? M_PI_4 * cos(M_PI * dist[i]/(2 * *bw))/ *bw : 0;
}
}
/* gaussian
* variant 2: fixed bandwidth, k nearest neighbors only
*/
void gaussian2 (double *weights, double *dist, int N, double *bw, int k) {
int i;
int index[N];
for (i = 0; i < N; i++) {
index[i] = i;
//Rprintf("index %u\n", index[i]);
}
rsort_with_index (dist, index, N);
/*for (i = 0; i < N; i++) {
Rprintf("dist0 %f\n", dist[i]);
Rprintf("index0 %u\n", index[i]);
}*/
for (i = 0; i < k; i++) {
weights[index[i]] = dnorm(dist[i], 0, *bw, 0);
}
}
/* exponential
* variant 2: fixed bandwidth, k nearest neighbors only
*/
void exponential2 (double *weights, double *dist, int N, double *bw, int k) {
int i;
int index[N];
for (i = 0; i < N; i++) {
index[i] = i;
//Rprintf("index %u\n", index[i]);
}
rsort_with_index (dist, index, N);
/*for (i = 0; i < N; i++) {
Rprintf("dist0 %f\n", dist[i]);
Rprintf("index0 %u\n", index[i]);
}*/
for (i = 0; i < k; i++) {
weights[index[i]] = 0.5 * exp(-fabs(dist[i])/ *bw)/ *bw;
}
}
/* cauchy
* variant 2: fixed bandwidth, k nearest neighbors only
*/
void cauchy2 (double *weights, double *dist, int N, double *bw, int k) {
int i;
int index[N];
for (i = 0; i < N; i++) {
index[i] = i;
//Rprintf("index %u\n", index[i]);
}
rsort_with_index (dist, index, N);
/*for (i = 0; i < N; i++) {
Rprintf("dist0 %f\n", dist[i]);
Rprintf("index0 %u\n", index[i]);
}*/
for (i = 0; i < k; i++) {
weights[index[i]] = 1/(M_PI * (1 + pow(dist[i]/ *bw, 2)) * *bw);
}
}
/* triangular
* variant 2: fixed bandwidth, k nearest neighbors only
*/
void triangular2 (double *weights, double *dist, int N, double *bw, int k) {
double adist;
int i;
int index[N];
for (i = 0; i < N; i++) {
index[i] = i;
//Rprintf("index %u\n", index[i]);
}
rsort_with_index (dist, index, N);
/*for (i = 0; i < N; i++) {
Rprintf("dist0 %f\n", dist[i]);
Rprintf("index0 %u\n", index[i]);
}*/
for (i = 0; i < k; i++) {
adist = fabs(dist[i]);
weights[index[i]] = adist < *bw ? (1 - adist/ *bw)/ *bw : 0;
}
}
/* epanechnikov
* variant 2: fixed bandwidth, k nearest neighbors only
*/
void epanechnikov2 (double *weights, double *dist, int N, double *bw, int k) {
double adist;
int i;
int index[N];
for (i = 0; i < N; i++) {
index[i] = i;
//Rprintf("index %u\n", index[i]);
}
rsort_with_index (dist, index, N);
/*for (i = 0; i < N; i++) {
Rprintf("dist0 %f\n", dist[i]);
Rprintf("index0 %u\n", index[i]);
}*/
for (i = 0; i < k; i++) {
adist = fabs(dist[i]);
weights[index[i]] = adist < *bw ? 0.75 * (1 - pow(adist/ *bw, 2))/ *bw : 0;
}
}
/*
Susceptible-Infectious-Removed MCMC analysis:
. Exponentially distributed infectiousness periods
*/
static void expLikelihood_SIR(double *parameters, double *infectionTimes,
double *removalTimes, int *N, int *nInfected, int *nRemoved,
double *sumSI, double *sumDurationInfectious, double *likelihood,
double *allTimes, int *indicator, int *SS, int *II)
{
int i,k=0,initialInfective=0, nEvents;
double sumLogBeta=0, sumLogInfections=0, sumDurationDensity=0, sumBetaSI=0;
nEvents = *nInfected+*nRemoved;
for(i = 0; i < *nInfected; ++i){
allTimes[(i*2)] = infectionTimes[i];
allTimes[(i*2)+1] = removalTimes[i];
indicator[(i*2)] = 2;
indicator[(i*2)+1] = 1;
if(removalTimes[i]==0){++initialInfective;}
}
rsort_with_index(allTimes,indicator,nEvents);
SS[0] = *N+initialInfective;
II[0] = 0;
for(i = 1; i < (nEvents+1); ++i){
if(indicator[(i-1)] == 2){
SS[i] = SS[(i-1)]-1;
II[i] = II[(i-1)]+1;}
else{
SS[i] = SS[(i-1)];
II[i] = II[(i-1)]-1;}
}
*sumSI = 0;
*sumDurationInfectious = 0;
/*sumLogBeta=(*nInfected-initialInfective)*log(parameters[0]);*/
for(i = 1; i < nEvents; ++i){/* "0" is the start of observation */
if(allTimes[i] != allTimes[i-1]){k = i;}
sumBetaSI+=parameters[0]*II[i]*SS[i]*(allTimes[i]-allTimes[(i-1)]);
if(indicator[i] == 1 && II[k] != 0){sumLogInfections+=log(II[k]);}
if(indicator[i] == 2 && II[k] != 0){sumLogInfections+=log(parameters[0]*SS[k]*II[k]);}
*sumSI+=SS[i]*II[i]*(allTimes[i]-allTimes[(i-1)]);
}
for(i = 0; i < *nRemoved; ++i){
sumDurationDensity+=dexp((removalTimes[i]-infectionTimes[i]),1/parameters[1],TRUE);
*sumDurationInfectious+=(removalTimes[i]-infectionTimes[i]);
}
*likelihood=sumLogBeta+sumLogInfections-sumBetaSI+sumDurationDensity;
}
void C_reorder(int *from, int *to, int *n, int *sumNode, int *neworder, int *root){
int i, j, sum=0, k, Nnode, ind, *ord, *csum, *tips, *stack, z=0; // l,
double *parent;
int m=sumNode[0];
parent = (double *) R_alloc((*n), sizeof(double));
tips = (int *) R_alloc(m, sizeof(int));
ord = (int *) R_alloc((*n), sizeof(int));
csum = (int *) R_alloc( (m+1), sizeof(int));
stack = (int *) R_alloc(m, sizeof(int));
for(j=0;j<(*n);j++) parent[j] = (double)from[j];
for(j=0;j<(*n);j++) ord[j] = j;
for(j=0;j<m;j++) tips[j] = 0;
rsort_with_index(parent, ord, *n);
tabulate(from, n, sumNode, tips);
csum[0]=0;
for(i=0;i<(*sumNode);i++){
sum+=tips[i];
csum[i+1] = sum;
}
k = (*n)-1;
Nnode = 0;
stack[0] = *root;
while(z > -1){
j=stack[z];
if(tips[j]>0){
for(i=csum[j];i<csum[j+1];i++){
ind = ord[i];
neworder[k] = ind + 1;
stack[z] = to[ind]-1;
k -=1;
z++;
}
Nnode += 1;
}
z--;
}
root[0]=Nnode;
}
static double
cmeans_weighted_median(double *x, double *w, int len)
{
int i;
double sum, val, marg, mval, cumsum_w, cumsum_w_x;
/* Sort x. */
for(i = 0; i < len; i++)
iwrk[i] = i;
rsort_with_index(x, iwrk, len);
/* Permute w using iwrk, and normalize. */
sum = 0;
for(i = 0; i < len; i++) {
dwrk[i] = w[iwrk[i]];
sum += dwrk[i];
}
for(i = 0; i < len; i++) {
w[i] = dwrk[i] / sum;
}
cumsum_w = cumsum_w_x = 0;
mval = R_PosInf;
marg = *x; /* -Wall */
for(i = 0; i < len; i++) {
cumsum_w += w[i];
cumsum_w_x += w[i] * x[i];
val = x[i] * (cumsum_w - .5) - cumsum_w_x;
if(val < mval) {
marg = x[i];
mval = val;
}
}
return(marg);
}
void C_surrogates(SEXP node, SEXP learnsample, SEXP weights, SEXP controls,
SEXP fitmem) {
SEXP x, y, expcovinf;
SEXP splitctrl, inputs;
SEXP split, thiswhichNA;
int nobs, ninputs, i, j, k, jselect, maxsurr, *order, nvar = 0;
double ms, cp, *thisweights, *cutpoint, *maxstat,
*splitstat, *dweights, *tweights, *dx, *dy;
double cut, *twotab, *ytmp, sumw = 0.0;
nobs = get_nobs(learnsample);
ninputs = get_ninputs(learnsample);
splitctrl = get_splitctrl(controls);
maxsurr = get_maxsurrogate(splitctrl);
inputs = GET_SLOT(learnsample, PL2_inputsSym);
jselect = S3get_variableID(S3get_primarysplit(node));
/* (weights > 0) in left node are the new `response' to be approximated */
y = S3get_nodeweights(VECTOR_ELT(node, S3_LEFT));
ytmp = Calloc(nobs, double);
for (i = 0; i < nobs; i++) {
ytmp[i] = REAL(y)[i];
if (ytmp[i] > 1.0) ytmp[i] = 1.0;
}
for (j = 0; j < ninputs; j++) {
if (is_nominal(inputs, j + 1)) continue;
nvar++;
}
nvar--;
if (maxsurr != LENGTH(S3get_surrogatesplits(node)))
error("nodes does not have %d surrogate splits", maxsurr);
if (maxsurr > nvar)
error("cannot set up %d surrogate splits with only %d ordered input variable(s)",
maxsurr, nvar);
tweights = Calloc(nobs, double);
dweights = REAL(weights);
for (i = 0; i < nobs; i++) tweights[i] = dweights[i];
if (has_missings(inputs, jselect)) {
thiswhichNA = get_missings(inputs, jselect);
for (k = 0; k < LENGTH(thiswhichNA); k++)
tweights[INTEGER(thiswhichNA)[k] - 1] = 0.0;
}
/* check if sum(weights) > 1 */
sumw = 0.0;
for (i = 0; i < nobs; i++) sumw += tweights[i];
if (sumw < 2.0)
error("can't implement surrogate splits, not enough observations available");
expcovinf = GET_SLOT(fitmem, PL2_expcovinfssSym);
C_ExpectCovarInfluence(ytmp, 1, tweights, nobs, expcovinf);
splitstat = REAL(get_splitstatistics(fitmem));
/* <FIXME> extend `TreeFitMemory' to those as well ... */
maxstat = Calloc(ninputs, double);
cutpoint = Calloc(ninputs, double);
order = Calloc(ninputs, int);
/* <FIXME> */
/* this is essentially an exhaustive search */
/* <FIXME>: we don't want to do this for random forest like trees
</FIXME>
*/
for (j = 0; j < ninputs; j++) {
order[j] = j + 1;
maxstat[j] = 0.0;
cutpoint[j] = 0.0;
/* ordered input variables only (for the moment) */
if ((j + 1) == jselect || is_nominal(inputs, j + 1))
continue;
x = get_variable(inputs, j + 1);
if (has_missings(inputs, j + 1)) {
/* update _tweights_ wrt missings in variable j + 1 */
thisweights = C_tempweights(j + 1, tweights, fitmem, inputs);
/* check if sum(weights) > 1 */
sumw = 0.0;
for (i = 0; i < nobs; i++) sumw += thisweights[i];
if (sumw < 2.0) continue;
C_ExpectCovarInfluence(ytmp, 1, thisweights, nobs, expcovinf);
C_split(REAL(x), 1, ytmp, 1, thisweights, nobs,
INTEGER(get_ordering(inputs, j + 1)), splitctrl,
GET_SLOT(fitmem, PL2_linexpcov2sampleSym),
expcovinf, 1, &cp, &ms, splitstat);
} else {
C_split(REAL(x), 1, ytmp, 1, tweights, nobs,
INTEGER(get_ordering(inputs, j + 1)), splitctrl,
GET_SLOT(fitmem, PL2_linexpcov2sampleSym),
expcovinf, 1, &cp, &ms, splitstat);
}
maxstat[j] = -ms;
cutpoint[j] = cp;
}
/* order with respect to maximal statistic */
rsort_with_index(maxstat, order, ninputs);
twotab = Calloc(4, double);
/* the best `maxsurr' ones are implemented */
for (j = 0; j < maxsurr; j++) {
if (is_nominal(inputs, order[j])) continue;
for (i = 0; i < 4; i++) twotab[i] = 0.0;
cut = cutpoint[order[j] - 1];
/* this might give warnings about split being
UNPROTECTed but is is since node is PROTECTed */
PROTECT(split = allocVector(VECSXP, SPLIT_LENGTH));
SET_VECTOR_ELT(S3get_surrogatesplits(node), j, split);
C_init_orderedsplit(split, 0);
S3set_variableID(split, order[j]);
REAL(S3get_splitpoint(split))[0] = cut;
dx = REAL(get_variable(inputs, order[j]));
dy = REAL(y);
/* OK, this is a dirty hack: determine if the split
goes left or right by the Pearson residual of a 2x2 table.
I don't want to use the big caliber here
*/
for (i = 0; i < nobs; i++) {
twotab[0] += ((dy[i] == 1) && (dx[i] <= cut)) * tweights[i];
twotab[1] += (dy[i] == 1) * tweights[i];
twotab[2] += (dx[i] <= cut) * tweights[i];
twotab[3] += tweights[i];
}
S3set_toleft(split, (int) (twotab[0] - twotab[1] * twotab[2] /
twotab[3]) > 0);
UNPROTECT(1);
}
Free(maxstat);
Free(cutpoint);
Free(order);
Free(tweights);
Free(twotab);
Free(ytmp);
}
void CNodeSearch::EvaluateCategoricalSplit()
{
long i=0;
unsigned long cFiniteMeans = 0;
if(fIsSplit) return;
if(cCurrentVarClasses == 0)
{
throw GBM::invalid_argument();
}
cFiniteMeans = 0;
for(i=0; i<cCurrentVarClasses; i++)
{
aiCurrentCategory[i] = i;
if(adGroupW[i] != 0.0)
{
adGroupMean[i] = adGroupSumZ[i]/adGroupW[i];
cFiniteMeans++;
}
else
{
adGroupMean[i] = HUGE_VAL;
}
}
rsort_with_index(&adGroupMean[0],&aiCurrentCategory[0],cCurrentVarClasses);
// if only one group has a finite mean it will not consider
// might be all are missing so no categories enter here
for(i=0; (cFiniteMeans>1) && ((ULONG)i<cFiniteMeans-1); i++)
{
dCurrentSplitValue = (double)i;
dCurrentLeftSumZ += adGroupSumZ[aiCurrentCategory[i]];
dCurrentLeftTotalW += adGroupW[aiCurrentCategory[i]];
cCurrentLeftN += acGroupN[aiCurrentCategory[i]];
dCurrentRightSumZ -= adGroupSumZ[aiCurrentCategory[i]];
dCurrentRightTotalW -= adGroupW[aiCurrentCategory[i]];
cCurrentRightN -= acGroupN[aiCurrentCategory[i]];
dCurrentImprovement =
CNode::Improvement(dCurrentLeftTotalW,dCurrentRightTotalW,
dCurrentMissingTotalW,
dCurrentLeftSumZ,dCurrentRightSumZ,
dCurrentMissingSumZ);
if((cCurrentLeftN >= cMinObsInNode) &&
(cCurrentRightN >= cMinObsInNode) &&
(dCurrentImprovement > dBestImprovement))
{
dBestSplitValue = dCurrentSplitValue;
if(iBestSplitVar != iCurrentSplitVar)
{
iBestSplitVar = iCurrentSplitVar;
cBestVarClasses = cCurrentVarClasses;
std::copy(aiCurrentCategory.begin(),
aiCurrentCategory.end(),
aiBestCategory.begin());
}
dBestLeftSumZ = dCurrentLeftSumZ;
dBestLeftTotalW = dCurrentLeftTotalW;
cBestLeftN = cCurrentLeftN;
dBestRightSumZ = dCurrentRightSumZ;
dBestRightTotalW = dCurrentRightTotalW;
cBestRightN = cCurrentRightN;
dBestImprovement = dCurrentImprovement;
}
}
}
/*----------------------------------------------------------------------- */
SEXP
watershed (SEXP x, SEXP _tolerance, SEXP _ext) {
SEXP res;
int im, i, j, nx, ny, nz, ext, nprotect = 0;
double tolerance;
nx = INTEGER ( GET_DIM(x) )[0];
ny = INTEGER ( GET_DIM(x) )[1];
nz = getNumberOfFrames(x,0);
tolerance = REAL( _tolerance )[0];
ext = INTEGER( _ext )[0];
PROTECT ( res = Rf_duplicate(x) );
nprotect++;
int * index = new int[ nx * ny ];
for ( im = 0; im < nz; im++ ) {
double * src = &( REAL(x)[ im * nx * ny ] );
double * tgt = &( REAL(res)[ im * nx * ny ] );
/* generate pixel index and negate the image -- filling wells */
for ( i = 0; i < nx * ny; i++ ) {
tgt[ i ] = -src[ i ];
index[ i ] = i;
}
/* from R includes R_ext/Utils.h */
/* will resort tgt as well */
rsort_with_index( tgt, index, nx * ny );
/* reassign tgt as it was reset above but keep new index */
for ( i = 0; i < nx * ny; i++ )
tgt[ i ] = -src[ i ];
SeedList seeds; /* indexes of all seed starting points, i.e. lowest values */
IntList equals; /* queue of all pixels on the same gray level */
IntList nb; /* seed values of assigned neighbours */
int ind, indxy, nbseed, x, y, topseed = 0;
IntList::iterator it;
TheSeed newseed;
PointXY pt;
bool isin;
/* loop through the sorted index */
for ( i = 0; i < nx * ny && src[ index[i] ] > BG; ) {
/* pool a queue of equally lowest values */
ind = index[ i ];
equals.push_back( ind );
for ( i = i + 1; i < nx * ny; ) {
if ( src[ index[i] ] != src[ ind ] ) break;
equals.push_back( index[i] );
i++;
}
while ( !equals.empty() ) {
/* first check through all the pixels if we can assign them to
* existing objects, count checked and reset counter on each assigned
* -- exit when counter equals queue length */
for ( j = 0; j < (int) equals.size(); ) {
if ((j%1000)==0) R_CheckUserInterrupt();
ind = equals.front();
equals.pop_front();
/* check neighbours:
* - if exists one, assign
* - if two or more check what should be combined and assign to the steepest
* - if none, push back */
/* reset j to 0 every time we assign another pixel to restart the loop */
nb.clear();
pt = pointFromIndex( ind, nx );
/* determine which neighbour we have, push them to nb */
for ( x = pt.x - ext; x <= pt.x + ext; x++ )
for ( y = pt.y - ext; y <= pt.y + ext; y++ ) {
if ( x < 0 || y < 0 || x >= nx || y >= ny || (x == pt.x && y == pt.y) ) continue;
indxy = x + y * nx;
nbseed = (int) tgt[ indxy ];
if ( nbseed < 1 ) continue;
isin = false;
for ( it = nb.begin(); it != nb.end() && !isin; it++ )
if ( nbseed == *it ) isin = true;
if ( !isin ) nb.push_back( nbseed );
}
if ( nb.size() == 0 ) {
/* push the pixel back and continue with the next one */
equals.push_back( ind );
j++;
continue;
}
tgt[ ind ] = check_multiple(tgt, src, ind, nb, seeds, tolerance, nx, ny );
/* we assigned the pixel, reset j to restart neighbours detection */
j = 0;
}
/* now we have assigned all that we could */
if ( !equals.empty() ) {
/* create a new seed for one pixel only and go back to assigning neighbours */
topseed++;
newseed.index = equals.front();
newseed.seed = topseed;
equals.pop_front();
tgt[ newseed.index ] = topseed;
seeds.push_back( newseed );
}
} // assigning equals
} // sorted index
/* now we need to reassign indexes while some seeds could be removed */
double * finseed = new double[ topseed ];
for ( i = 0; i < topseed; i++ )
finseed[ i ] = 0;
i = 0;
while ( !seeds.empty() ) {
newseed = seeds.front();
seeds.pop_front();
finseed[ newseed.seed - 1 ] = i + 1;
i++;
}
for ( i = 0; i < nx * ny; i++ ) {
j = (int) tgt[ i ];
if ( 0 < j && j <= topseed )
tgt[ i ] = finseed[ j - 1 ];
}
delete[] finseed;
} // loop through images
delete[] index;
UNPROTECT (nprotect);
return res;
}
void fitqtl_imp_binary(int n_ind, int n_qtl, int *n_gen, int n_draws,
int ***Draws, double **Cov, int n_cov,
int *model, int n_int, double *pheno, int get_ests,
double *lod, int *df, double *ests, double *ests_covar,
double *design_mat, double tol, int maxit, int *matrix_rank)
{
/* create local variables */
int i, j, ii, jj, n_qc, itmp; /* loop variants and temp variables */
double llik, llik0, *LOD_array;
double *the_ests, *the_covar, **TheEsts, ***TheCovar;
double *dwork, **Ests_covar, tot_wt=0.0, *wts;
double **Covar_mean, **Mean_covar, *mean_ests; /* for ests and cov matrix */
int *iwork, sizefull, n_trim, *index;
/* number to trim from each end of the imputations */
n_trim = (int) floor( 0.5*log(n_draws)/log(2.0) );
/* initialization */
sizefull = 1;
/* calculate the dimension of the design matrix for full model */
n_qc = n_qtl+n_cov; /* total number of QTLs and covariates */
/* for additive QTLs and covariates*/
for(i=0; i<n_qc; i++)
sizefull += n_gen[i];
/* for interactions, loop thru all interactions */
for(i=0; i<n_int; i++) {
for(j=0, itmp=1; j<n_qc; j++) {
if(model[i*n_qc+j])
itmp *= n_gen[j];
}
sizefull += itmp;
}
/* reorganize Ests_covar for easy use later */
/* and make space for estimates and covariance matrix */
if(get_ests) {
reorg_errlod(sizefull, sizefull, ests_covar, &Ests_covar);
allocate_double(sizefull*n_draws, &the_ests);
allocate_double(sizefull*sizefull*n_draws, &the_covar);
/* I need to save all of the estimates and covariance matrices */
reorg_errlod(sizefull, n_draws, the_ests, &TheEsts);
reorg_genoprob(sizefull, sizefull, n_draws, the_covar, &TheCovar);
allocate_dmatrix(sizefull, sizefull, &Mean_covar);
allocate_dmatrix(sizefull, sizefull, &Covar_mean);
allocate_double(sizefull, &mean_ests);
allocate_double(n_draws, &wts);
}
/* allocate memory for working arrays, total memory is
sizefull*n_ind+6*n_ind+4*sizefull for double array,
and sizefull for integer array.
All memory will be allocated one time and split later */
dwork = (double *)R_alloc(sizefull*n_ind+6*n_ind+4*sizefull,
sizeof(double));
iwork = (int *)R_alloc(sizefull, sizeof(int));
index = (int *)R_alloc(n_draws, sizeof(int));
LOD_array = (double *)R_alloc(n_draws, sizeof(double));
/* calculate null model log10 likelihood */
llik0 = nullLODbin(pheno, n_ind);
*matrix_rank = n_ind;
/* loop over imputations */
for(i=0; i<n_draws; i++) {
R_CheckUserInterrupt(); /* check for ^C */
/* calculate alternative model RSS */
llik = galtLODimpbin(pheno, n_ind, n_gen, n_qtl, Draws[i],
Cov, n_cov, model, n_int, dwork, iwork, sizefull,
get_ests, ests, Ests_covar, design_mat,
tol, maxit, matrix_rank);
/* calculate the LOD score in this imputation */
LOD_array[i] = (llik - llik0);
/* if getting estimates, calculate the weights */
if(get_ests) {
wts[i] = LOD_array[i]*log(10.0);
if(i==0) tot_wt = wts[i];
else tot_wt = addlog(tot_wt, wts[i]);
for(ii=0; ii<sizefull; ii++) {
TheEsts[i][ii] = ests[ii];
for(jj=ii; jj<sizefull; jj++)
TheCovar[i][ii][jj] = Ests_covar[ii][jj];
}
}
} /* end loop over imputations */
/* sort the lod scores, and trim the weights */
if(get_ests) {
for(i=0; i<n_draws; i++) {
index[i] = i;
wts[i] = exp(wts[i]-tot_wt);
}
rsort_with_index(LOD_array, index, n_draws);
for(i=0; i<n_trim; i++)
wts[index[i]] = wts[index[n_draws-i-1]] = 0.0;
/* re-scale wts */
tot_wt = 0.0;
for(i=0; i<n_draws; i++) tot_wt += wts[i];
for(i=0; i<n_draws; i++) wts[i] /= tot_wt;
}
/* calculate the result LOD score */
*lod = wtaverage(LOD_array, n_draws);
/* degree of freedom equals to the number of columns of x minus 1 (mean) */
*df = sizefull - 1;
/* get means and variances and covariances of estimates */
if(get_ests) {
for(i=0; i<n_draws; i++) {
if(i==0) {
for(ii=0; ii<sizefull; ii++) {
mean_ests[ii] = TheEsts[i][ii] * wts[i];
for(jj=ii; jj<sizefull; jj++) {
Mean_covar[ii][jj] = TheCovar[i][ii][jj] * wts[i];
Covar_mean[ii][jj] = 0.0;
}
}
}
else {
for(ii=0; ii<sizefull; ii++) {
mean_ests[ii] += TheEsts[i][ii]*wts[i];
for(jj=ii; jj<sizefull; jj++) {
Mean_covar[ii][jj] += TheCovar[i][ii][jj]*wts[i];
Covar_mean[ii][jj] += (TheEsts[i][ii]-TheEsts[0][ii])*
(TheEsts[i][jj]-TheEsts[0][jj])*wts[i];
}
}
}
}
for(i=0; i<sizefull; i++) {
ests[i] = mean_ests[i];
for(j=i; j<sizefull; j++) {
Covar_mean[i][j] = (Covar_mean[i][j] - (mean_ests[i]-TheEsts[0][i])*
(mean_ests[j]-TheEsts[0][j]))*(double)n_draws/(double)(n_draws-1);
Ests_covar[i][j] = Ests_covar[j][i] = Mean_covar[i][j] + Covar_mean[i][j];
}
}
} /* done getting estimates */
}
void devol(double VTR, double d_weight, double d_cross, int i_bs_flag,
double *d_lower, double *d_upper, SEXP fcall, SEXP rho, int trace,
int i_strategy, int i_D, int i_NP, int i_itermax,
double *initialpopv, int i_storepopfrom, int i_storepopfreq,
int i_specinitialpop,
double *gt_bestP, double *gt_bestC,
double *gd_pop, double *gd_storepop, double *gd_bestmemit, double *gd_bestvalit,
int *gi_iter, double d_pPct, double d_c, long *l_nfeval,
double d_reltol, int i_steptol, SEXP fnMap)
{
#define URN_DEPTH 5 /* 4 + one index to avoid */
int P=0;
/* initialize parameter vector to pass to evaluate function */
SEXP par;
PROTECT(par = NEW_NUMERIC(i_D)); P++;
double *d_par = REAL(par);
/* Data structures for parameter vectors */
SEXP sexp_gta_popP, sexp_gta_oldP, sexp_gta_newP, sexp_map_pop;
PROTECT(sexp_gta_popP = allocMatrix(REALSXP, i_NP, i_D)); P++; /* FIXME THIS HAD 2x the rows!!! */
PROTECT(sexp_gta_oldP = allocMatrix(REALSXP, i_NP, i_D)); P++;
PROTECT(sexp_gta_newP = allocMatrix(REALSXP, i_NP, i_D)); P++;
double *ngta_popP = REAL(sexp_gta_popP); /* FIXME THIS HAD 2x the rows!!! */
double *ngta_oldP = REAL(sexp_gta_oldP);
double *ngta_newP = REAL(sexp_gta_newP);
/* Data structures for objective function values associated with
* parameter vectors */
SEXP sexp_gta_popC, sexp_gta_oldC, sexp_gta_newC;
PROTECT(sexp_gta_popC = allocVector(REALSXP, i_NP)); P++;
PROTECT(sexp_gta_oldC = allocVector(REALSXP, i_NP)); P++;
PROTECT(sexp_gta_newC = allocVector(REALSXP, i_NP)); P++;
double *ngta_popC = REAL(sexp_gta_popC);
double *ngta_oldC = REAL(sexp_gta_oldC);
double *ngta_newC = REAL(sexp_gta_newC);
double *gta_popC = (double *)R_alloc(i_NP*2,sizeof(double));
double *gta_oldC = (double *)R_alloc(i_NP,sizeof(double));
double *gta_newC = (double *)R_alloc(i_NP,sizeof(double));
double *t_bestitP = (double *)R_alloc(1,sizeof(double) * i_D);
double *t_tmpP = (double *)R_alloc(1,sizeof(double) * i_D);
double *tempP = (double *)R_alloc(1,sizeof(double) * i_D);
SEXP sexp_t_tmpP, sexp_t_tmpC;
PROTECT(sexp_t_tmpP = allocMatrix(REALSXP, i_NP, i_D)); P++;
PROTECT(sexp_t_tmpC = allocVector(REALSXP, i_NP)); P++;
double *nt_tmpP = REAL(sexp_t_tmpP);
double *nt_tmpC = REAL(sexp_t_tmpC);
int i, j, k; /* counting variables */
int i_r1, i_r2, i_r3; /* placeholders for random indexes */
int ia_urn2[URN_DEPTH];
int ia_urnTemp[i_NP];
int i_nstorepop, i_xav;
i_nstorepop = ceil((i_itermax - i_storepopfrom) / i_storepopfreq);
int popcnt, bestacnt, same; /* lazy cnters */
double d_jitter, d_dither;
double t_tmpC, tmp_best, t_bestC;
double **initialpop = (double **)R_alloc(i_NP,sizeof(double *));
for (int i = 0; i < i_NP; i++)
initialpop[i] = (double *)R_alloc(i_D,sizeof(double));
/* vars for DE/current-to-p-best/1 */
int i_pbest;
int p_NP = round(d_pPct * i_NP); /* choose at least two best solutions */
p_NP = p_NP < 2 ? 2 : p_NP;
int sortIndex[i_NP]; /* sorted values of gta_oldC */
for(i = 0; i < i_NP; i++) sortIndex[i] = i;
//double goodCR = 0, goodF = 0, goodF2 = 0, meanCR = 0.5, meanF = 0.5;
double goodCR = 0, goodF = 0, goodF2 = 0, meanCR = d_cross, meanF = d_weight;
int i_goodNP = 0;
/* vars for when i_bs_flag == 1 */
// int i_len, done, step, bound;
// double tempC;
GetRNGstate();
/* if initial population provided, initialize with values */
if (i_specinitialpop > 0) {
k = 0;
for (j = 0; j < i_D; j++) {
for (i = 0; i < i_NP; i++) {
initialpop[i][j] = initialpopv[k];
k += 1;
}
}
}
/*------Initialization-----------------------------*/
for (j = 0; j < i_D; j++) {
for (i = 0; i < i_NP; i++) {
if (i_specinitialpop <= 0) { /* random initial member */
ngta_popP[i+i_NP*j] = d_lower[j] +
unif_rand() * (d_upper[j] - d_lower[j]);
}
else /* or user-specified initial member */
ngta_popP[i+i_NP*j] = initialpop[i][j];
}
}
PROTECT(sexp_map_pop = popEvaluate(l_nfeval, sexp_gta_popP, fnMap, rho, 0));
memmove(REAL(sexp_gta_popP), REAL(sexp_map_pop), i_NP * i_D * sizeof(double)); // valgrind reports memory overlap here
UNPROTECT(1); // sexp_map_pop
PROTECT(sexp_gta_popC = popEvaluate(l_nfeval, sexp_gta_popP, fcall, rho, 1));
ngta_popC = REAL(sexp_gta_popC);
for (i = 0; i < i_NP; i++) {
if (i == 0 || ngta_popC[i] <= t_bestC) {
t_bestC = ngta_popC[i];
for (j = 0; j < i_D; j++)
gt_bestP[j]=ngta_popP[i+i_NP*j];
}
}
/*---assign pointers to current ("old") population---*/
memcpy(REAL(sexp_gta_oldP), REAL(sexp_gta_popP), i_NP * i_D * sizeof(double));
memcpy(REAL(sexp_gta_oldC), REAL(sexp_gta_popC), i_NP * sizeof(double));
UNPROTECT(1); // sexp_gta_popC
/*------Iteration loop--------------------------------------------*/
int i_iter = 0;
popcnt = 0;
bestacnt = 0;
i_xav = 1;
int i_iter_tol = 0;
while ((i_iter < i_itermax) && (t_bestC > VTR) && (i_iter_tol <= i_steptol))
{
/* store intermediate populations */
if (i_iter % i_storepopfreq == 0 && i_iter >= i_storepopfrom) {
for (i = 0; i < i_NP; i++) {
for (j = 0; j < i_D; j++) {
gd_storepop[popcnt] = ngta_oldP[i+i_NP*j];
popcnt++;
}
}
} /* end store pop */
/* store the best member */
for(j = 0; j < i_D; j++) {
gd_bestmemit[bestacnt] = gt_bestP[j];
bestacnt++;
}
/* store the best value */
gd_bestvalit[i_iter] = t_bestC;
for (j = 0; j < i_D; j++)
t_bestitP[j] = gt_bestP[j];
i_iter++;
/*----compute dithering factor -----------------*/
if (i_strategy == 5)
d_dither = d_weight + unif_rand() * (1.0 - d_weight);
/*---DE/current-to-p-best/1 ----------------------------------------------*/
if (i_strategy == 6) {
/* create a copy of gta_oldC to avoid changing it */
double temp_oldC[i_NP];
for(j = 0; j < i_NP; j++) temp_oldC[j] = ngta_oldC[j];
/* sort temp_oldC to use sortIndex later */
rsort_with_index( (double*)temp_oldC, (int*)sortIndex, i_NP );
}
/*----start of loop through ensemble------------------------*/
for (i = 0; i < i_NP; i++) {
/*t_tmpP is the vector to mutate and eventually select*/
for (j = 0; j < i_D; j++)
nt_tmpP[i+i_NP*j] = ngta_oldP[i+i_NP*j];
nt_tmpC[i] = ngta_oldC[i];
permute(ia_urn2, URN_DEPTH, i_NP, i, ia_urnTemp); /* Pick 4 random and distinct */
i_r1 = ia_urn2[1]; /* population members */
i_r2 = ia_urn2[2];
i_r3 = ia_urn2[3];
if (d_c > 0) {
d_cross = rnorm(meanCR, 0.1);
d_cross = d_cross > 1.0 ? 1 : d_cross;
d_cross = d_cross < 0.0 ? 0 : d_cross;
do {
d_weight = rcauchy(meanF, 0.1);
d_weight = d_weight > 1 ? 1.0 : d_weight;
}while(d_weight <= 0.0);
}
/*===Choice of strategy===============================================*/
j = (int)(unif_rand() * i_D); /* random parameter */
k = 0;
do {
switch (i_strategy) {
case 1: { /*---classical strategy DE/rand/1/bin-------------------*/
nt_tmpP[i+i_NP*j] = ngta_oldP[i_r1+i_NP*j] +
d_weight * (ngta_oldP[i_r2+i_NP*j] - ngta_oldP[i_r3+i_NP*j]);
break;
}
case 2: { /*---DE/local-to-best/1/bin-----------------------------*/
nt_tmpP[i+i_NP*j] = nt_tmpP[i+i_NP*j] +
d_weight * (t_bestitP[j] - nt_tmpP[i+i_NP*j]) +
d_weight * (ngta_oldP[i_r2+i_NP*j] - ngta_oldP[i_r3+i_NP*j]);
break;
}
case 3: { /*---DE/best/1/bin with jitter--------------------------*/
d_jitter = 0.0001 * unif_rand() + d_weight;
nt_tmpP[i+i_NP*j] = t_bestitP[j] +
d_jitter * (ngta_oldP[i_r1+i_NP*j] - ngta_oldP[i_r2+i_NP*j]);
break;
}
case 4: { /*---DE/rand/1/bin with per-vector-dither---------------*/
nt_tmpP[i+i_NP*j] = ngta_oldP[i_r1+i_NP*j] +
(d_weight + unif_rand()*(1.0 - d_weight))*
(ngta_oldP[i_r2+i_NP*j]-ngta_oldP[i_r3+i_NP*j]);
break;
}
case 5: { /*---DE/rand/1/bin with per-generation-dither-----------*/
nt_tmpP[i+i_NP*j] = ngta_oldP[i_r1+i_NP*j] +
d_dither * (ngta_oldP[i_r2+i_NP*j] - ngta_oldP[i_r3+i_NP*j]);
break;
}
case 6: { /*---DE/current-to-p-best/1 (JADE)----------------------*/
/* select from [0, 1, 2, ..., (pNP-1)] */
i_pbest = sortIndex[(int)(unif_rand() * p_NP)];
nt_tmpP[i+i_NP*j] = ngta_oldP[i+i_NP*j] +
d_weight * (ngta_oldP[i_pbest+i_NP*j] - ngta_oldP[i+i_NP*j]) +
d_weight * (ngta_oldP[i_r1+i_NP*j] - ngta_oldP[i_r2+i_NP*j]);
break;
}
default: { /*---variation to DE/rand/1/bin: either-or-algorithm---*/
if (unif_rand() < 0.5) { /* differential mutation, Pmu = 0.5 */
nt_tmpP[i+i_NP*j] = ngta_oldP[i_r1+i_NP*j] + d_weight *
(ngta_oldP[i_r2+i_NP*j] - ngta_oldP[i_r3+i_NP*j]);
} else {
/* recombination with K = 0.5*(F+1) -. F-K-Rule */
nt_tmpP[i+i_NP*j] = ngta_oldP[i_r1+i_NP*j] +
0.5 * (d_weight + 1.0) * (ngta_oldP[i_r2+i_NP*j]
+ ngta_oldP[i_r3+i_NP*j] - 2 * ngta_oldP[i_r1+i_NP*j]);
}
}
} /* end switch */
j = (j + 1) % i_D;
k++;
}while((unif_rand() < d_cross) && (k < i_D));
/*===End choice of strategy===========================================*/
/*----boundary constraints, bounce-back method was not enforcing bounds correctly*/
for (j = 0; j < i_D; j++) {
if (nt_tmpP[i+i_NP*j] < d_lower[j]) {
nt_tmpP[i+i_NP*j] = d_lower[j] + unif_rand() * (d_upper[j] - d_lower[j]);
}
if (nt_tmpP[i+i_NP*j] > d_upper[j]) {
nt_tmpP[i+i_NP*j] = d_upper[j] - unif_rand() * (d_upper[j] - d_lower[j]);
}
}
} /* NEW End mutation loop through ensemble */
/*------Trial mutation now in t_tmpP-----------------*/
/* evaluate mutated population */
PROTECT(sexp_map_pop = popEvaluate(l_nfeval, sexp_t_tmpP, fnMap, rho, 0));
memmove(REAL(sexp_t_tmpP), REAL(sexp_map_pop), i_NP * i_D * sizeof(double)); // valgrind reports memory overlap here
UNPROTECT(1); // sexp_map_pop
PROTECT(sexp_t_tmpC = popEvaluate(l_nfeval, sexp_t_tmpP, fcall, rho, 1));
nt_tmpC = REAL(sexp_t_tmpC);
/* compare old pop with mutated pop */
for (i = 0; i < i_NP; i++) {
/* note that i_bs_flag means that we will choose the
*best NP vectors from the old and new population later*/
if (nt_tmpC[i] <= ngta_oldC[i] || i_bs_flag) {
/* replace target with mutant */
for (j = 0; j < i_D; j++)
ngta_newP[i+i_NP*j]=nt_tmpP[i+i_NP*j];
ngta_newC[i]=nt_tmpC[i];
if (nt_tmpC[i] <= t_bestC) {
for (j = 0; j < i_D; j++)
gt_bestP[j]=nt_tmpP[i+i_NP*j];
t_bestC=nt_tmpC[i];
}
if (d_c > 0) { /* calculate new goodCR and goodF */
goodCR += d_cross / ++i_goodNP;
goodF += d_weight;
goodF2 += pow(d_weight,2.0);
}
}
else {
for (j = 0; j < i_D; j++)
ngta_newP[i+i_NP*j]=ngta_oldP[i+i_NP*j];
ngta_newC[i]=ngta_oldC[i];
}
} /* End mutation loop through ensemble */
UNPROTECT(1); // sexp_t_tmpC
if (d_c > 0) { /* calculate new meanCR and meanF */
meanCR = (1-d_c)*meanCR + d_c*goodCR;
meanF = (1-d_c)*meanF + d_c*goodF2/goodF;
}
if(i_bs_flag) { /* FIXME */
error("bs = TRUE not currently supported");
// /* examine old and new pop. and take the best NP members
// * into next generation */
// for (i = 0; i < i_NP; i++) {
// for (j = 0; j < i_D; j++)
// gta_popP[i][j] = gta_oldP[i][j];
// gta_popC[i] = gta_oldC[i];
// }
// for (i = 0; i < i_NP; i++) {
// for (j = 0; j < i_D; j++)
// gta_popP[i_NP+i][j] = gta_newP[i][j];
// gta_popC[i_NP+i] = gta_newC[i];
// }
// i_len = 2 * i_NP;
// step = i_len; /* array length */
// while (step > 1) {
// step /= 2; /* halve the step size */
// do {
// done = 1;
// bound = i_len - step;
// for (j = 0; j < bound; j++) {
// i = j + step + 1;
// if (gta_popC[j] > gta_popC[i-1]) {
// for (k = 0; k < i_D; k++)
// tempP[k] = gta_popP[i-1][k];
// tempC = gta_popC[i-1];
// for (k = 0; k < i_D; k++)
// gta_popP[i-1][k] = gta_popP[j][k];
// gta_popC[i-1] = gta_popC[j];
// for (k = 0; k < i_D; k++)
// gta_popP[j][k] = tempP[k];
// gta_popC[j] = tempC;
// done = 0;
// /* if a swap has been made we are not finished yet */
// } /* if */
// } /* for */
// } while (!done); /* while */
// } /*while (step > 1) */
// /* now the best NP are in first NP places in gta_pop, use them */
// for (i = 0; i < i_NP; i++) {
// for (j = 0; j < i_D; j++)
// gta_newP[i][j] = gta_popP[i][j];
// gta_newC[i] = gta_popC[i];
// }
} /*i_bs_flag*/
/* have selected NP mutants move on to next generation */
for (i = 0; i < i_NP; i++) {
for (j = 0; j < i_D; j++)
ngta_oldP[i+i_NP*j] = ngta_newP[i+i_NP*j];
ngta_oldC[i] = ngta_newC[i];
}
for (j = 0; j < i_D; j++)
t_bestitP[j] = gt_bestP[j];
if( trace > 0 ) {
if( (i_iter % trace) == 0 ) {
Rprintf("Iteration: %d bestvalit: %f bestmemit:", i_iter, t_bestC);
for (j = 0; j < i_D; j++)
Rprintf("%12.6f", gt_bestP[j]);
Rprintf("\n");
}
}
/* check for user interrupt */
/*if( i_iter % 10000 == 999 ) R_CheckUserInterrupt();*/
/* check relative tolerance (as in src/main/optim.c) */
/* kmm: not sure where the above is, but was not working as
advertised in help file; changed
*/
if( fabs(t_bestC - gd_bestvalit[i_iter-1]) <
(d_reltol * (fabs(gd_bestvalit[i_iter-1]) + d_reltol))) {
i_iter_tol++;
} else {
i_iter_tol = 0;
}
} /* end iteration loop */
/* last population */
k = 0;
for (i = 0; i < i_NP; i++) {
for (j = 0; j < i_D; j++) {
gd_pop[k] = ngta_oldP[i+i_NP*j];
k++;
}
}
*gi_iter = i_iter;
*gt_bestC = t_bestC;
PutRNGstate();
UNPROTECT(P);
}
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;
}
/* estimate coincidence function */
void est_coi(int n_ind, int n_mar, int n_pair,
double *map, int **Geno, double *d,
double *coi1, double *coi2,
int *n_keep, double window)
{
double *rf, *mapd, *top, *bottom, *temp, *work;
int i, j, k, s, nmarm1, *temp_idx;
nmarm1 = n_mar - 1;
/* allocate space */
rf = (double *)R_alloc(nmarm1, sizeof(double));
mapd = (double *)R_alloc(nmarm1, sizeof(double));
top = (double *)R_alloc(n_pair, sizeof(double));
bottom = (double *)R_alloc(n_pair, sizeof(double));
temp = (double *)R_alloc(n_pair, sizeof(double));
temp_idx = (int *)R_alloc(n_pair, sizeof(int));
work = (double *)R_alloc(n_pair, sizeof(double));
R_CheckUserInterrupt(); /* check for ^C */
/* midpoints of intervals */
for(i=0; i<nmarm1; i++)
mapd[i] = (map[i]+map[i+1])/2.0;
R_CheckUserInterrupt(); /* check for ^C */
/* inter-interval distances */
for(j=0, s=0; j<nmarm1-1; j++)
for(k=(j+1); k<nmarm1; k++, s++)
d[s] = mapd[k] - mapd[j];
R_CheckUserInterrupt(); /* check for ^C */
/* recombination fractions */
for(j=0; j<nmarm1; j++) {
rf[j] = 0.0;
for(i=0; i<n_ind; i++) {
if(Geno[j][i] != Geno[j+1][i])
rf[j] += 1.0;
}
rf[j] /= (double)n_ind;
R_CheckUserInterrupt(); /* check for ^C */
}
/* top and bottom of the coincidence function */
for(j=0, s=0; j<nmarm1-1; j++) {
for(k=(j+1); k<nmarm1; k++, s++) {
top[s] = 0.0;
bottom[s] = rf[j]*rf[k];
for(i=0; i<n_ind; i++) {
if(Geno[j][i] != Geno[j+1][i] &&
Geno[k][i] != Geno[k+1][i])
top[s] += 1.0;
}
top[s] /= (double)n_ind;
R_CheckUserInterrupt(); /* check for ^C */
}
}
/* ratio, then smooth */
for(i=0; i<n_pair; i++) {
if(fabs(bottom[i]) < 1e-12) coi2[i] = NA_REAL; /* to be ignored */
else coi2[i] = top[i]/bottom[i];
}
R_CheckUserInterrupt(); /* check for ^C */
/* sort d, and also top and bottom to match */
/* first, create an index */
for(i=0; i<n_pair; i++)
temp_idx[i] = i;
rsort_with_index(d, temp_idx, n_pair);
R_CheckUserInterrupt(); /* check for ^C */
/* sort then running means on coi2 */
for(i=0; i<n_pair; i++)
temp[i] = coi2[temp_idx[i]];
runningmean(n_pair, d, temp, coi2, window, 2, work);
R_CheckUserInterrupt(); /* check for ^C */
/* sort top and then do running mean */
for(i=0; i<n_pair; i++)
temp[i] = top[temp_idx[i]];
runningmean(n_pair, d, temp, top, window, 2, work);
R_CheckUserInterrupt(); /* check for ^C */
/* sort bottom and then do running mean */
for(i=0; i<n_pair; i++)
temp[i] = bottom[temp_idx[i]];
runningmean(n_pair, d, temp, bottom, window, 2, work);
R_CheckUserInterrupt(); /* check for ^C */
for(i=0; i<n_pair; i++)
coi1[i] = top[i]/bottom[i];
R_CheckUserInterrupt(); /* check for ^C */
/* now just save the unique values */
for(j=0, i=1, *n_keep=1; i<n_pair; i++) {
if(d[i] > d[j]) {
coi1[*n_keep] = coi1[i];
coi2[*n_keep] = coi2[i];
d[*n_keep] = d[i];
(*n_keep)++;
j = i;
}
}
}
