SEXP bicomponents_R(SEXP net, SEXP sn, SEXP sm)
{
snaNet *g;
int *parent,*num,*back,*dfn,i,j,n,count,pc=0;
element *complist,*ep,*ep2,*es;
SEXP bicomps,bcl,memb,outlist;
/*Coerce what needs coercin'*/
//Rprintf("Initial coercion\n");
PROTECT(sn=coerceVector(sn,INTSXP)); pc++;
PROTECT(sm=coerceVector(sm,INTSXP)); pc++;
PROTECT(net=coerceVector(net,REALSXP)); pc++;
n=INTEGER(sn)[0];
/*Initialize sna internal network*/
GetRNGstate();
g=elMatTosnaNet(REAL(net),INTEGER(sn),INTEGER(sm));
/*Calculate the sorting stat*/
parent=(int *)R_alloc(n,sizeof(int));
num=(int *)R_alloc(n,sizeof(int));
back=(int *)R_alloc(n,sizeof(int));
dfn=(int *)R_alloc(1,sizeof(int));
for(i=0;i<n;i++){
parent[i]=-1;
num[i]=0;
back[i]=n+1;
}
*dfn=0;
/*Initialize the component list*/
complist=(element *)R_alloc(1,sizeof(element));
complist->val=0.0;
complist->next=NULL;
complist->dp=NULL;
/*Walk the graph components, finding bicomponents*/
es=(element *)R_alloc(1,sizeof(element));
for(i=0;i<n;i++)
if(num[i]==0){
es->next=NULL;
bicomponentRecurse(g,complist,es,parent,num,back,dfn,i);
}
/*Transfer information from complist to output vector*/
//Rprintf("Gathering components...\n");
count=(int)complist->val;
PROTECT(outlist=allocVector(VECSXP,2)); pc++;
PROTECT(bicomps=allocVector(VECSXP,count)); pc++;
PROTECT(memb=allocVector(INTSXP,n)); pc++;
for(i=0;i<n;i++) /*Initialize memberships, since some have none*/
INTEGER(memb)[i]=-1;
ep=complist->next;
for(i=0;i<count;i++){
PROTECT(bcl=allocVector(INTSXP,(int)ep->val));
j=0;
for(ep2=(element *)ep->dp;ep2!=NULL;ep2=ep2->next){
INTEGER(bcl)[j++]=(int)ep2->val+1;
INTEGER(memb)[(int)ep2->val]=i+1;
}
SET_VECTOR_ELT(bicomps,i,bcl);
UNPROTECT(1);
ep=ep->next;
}
SET_VECTOR_ELT(outlist,0,bicomps);
SET_VECTOR_ELT(outlist,1,memb);
/*Unprotect and return*/
PutRNGstate();
UNPROTECT(pc);
return outlist;
}
SEXP svi(SEXP R_T, SEXP R_P, SEXP R_j, SEXP R_p, SEXP R_nIter, SEXP R_m) {
int T, P, nIter, k, h;
int *jM, *pM, iter, i, j;
double *mPostU, *vPostU, *mPostV, *vPostV, *mPostB, *vPostB, *mPriorU,
*mPriorV, *vPriorUi, *vPriorUh, *vPriorVj, *vPriorVh,
vPriorB, mPriorB, mPred, vPred, e, *e0, rho;
int *nZerosAuxi, *nOnesAuxi, *nZerosAuxj, *nOnesAuxj, *nOnesSampling,
*nZerosSampling;
/* We read in the random number generator seed */
GetRNGstate();
/* We map the R variables to c variables */
jM = INTEGER_POINTER(R_j);
pM = INTEGER_POINTER(R_p);
T = *INTEGER_POINTER(R_T);
P = *INTEGER_POINTER(R_P);
nIter = *INTEGER_POINTER(R_nIter);
mPostU = NUMERIC_POINTER(getListElement(R_m, "mPostU"));
vPostU = NUMERIC_POINTER(getListElement(R_m, "vPostU"));
mPostV = NUMERIC_POINTER(getListElement(R_m, "mPostV"));
vPostV = NUMERIC_POINTER(getListElement(R_m, "vPostV"));
mPostB = NUMERIC_POINTER(getListElement(R_m, "mPostB"));
vPostB = NUMERIC_POINTER(getListElement(R_m, "vPostB"));
mPriorU = NUMERIC_POINTER(getListElement(R_m, "mPriorU"));
mPriorV = NUMERIC_POINTER(getListElement(R_m, "mPriorV"));
vPriorUi = NUMERIC_POINTER(getListElement(R_m, "vPriorUi"));
vPriorUh = NUMERIC_POINTER(getListElement(R_m, "vPriorUh"));
mPriorU = NUMERIC_POINTER(getListElement(R_m, "mPriorU"));
vPriorVj = NUMERIC_POINTER(getListElement(R_m, "vPriorVj"));
vPriorVh = NUMERIC_POINTER(getListElement(R_m, "vPriorVh"));
mPriorB = *NUMERIC_POINTER(getListElement(R_m, "mPriorB"));
vPriorB = *NUMERIC_POINTER(getListElement(R_m, "vPriorB"));
e0 = NUMERIC_POINTER(getListElement(R_m, "e0"));
k = *INTEGER_POINTER(getListElement(R_m, "k"));
nOnesAuxi = INTEGER_POINTER(getListElement(R_m, "nOnesAuxi"));
nOnesAuxj = INTEGER_POINTER(getListElement(R_m, "nOnesAuxj"));
nZerosAuxi = INTEGER_POINTER(getListElement(R_m, "nZerosAuxi"));
nZerosAuxj = INTEGER_POINTER(getListElement(R_m, "nZerosAuxj"));
nOnesSampling = INTEGER_POINTER(getListElement(R_m, "nOnesSampling"));
nZerosSampling =
INTEGER_POINTER(getListElement(R_m, "nZerosSampling"));
/* We start the stochastic optimization */
for (iter = 1 ; iter <= nIter ; iter++) {
rho = 0.01;
if (unif_rand() <= 0.5) {
/* We sample the row and column of a positive entry */
samplePositiveEntry(jM, pM, T, nOnesSampling, &i, &j);
/* We compute the predictive mean and variance */
mPred = 0;
vPred = 0;
for (h = 0 ; h < k ; h++) {
mPred += mPostU[ i + h * T ] *
mPostV[ j + h * P ];
vPred += mPostU[ i + h * T ] *
mPostU[ i + h * T ] *
vPostV[ j + h * P ] +
vPostU[ i + h * T ] *
mPostV[ j + h * P ] *
mPostV[ j + h * P ] +
vPostU[ i + h * T ] *
vPostV[ j + h * P ];
}
mPred += *mPostB;
vPred += *vPostB;
/* We refine the parameters for the i-th row of U */
refineRowUPositive(mPostU, vPostU, mPostV, vPostV,
vPriorUi, vPriorUh, mPriorU, &mPred, &vPred,
i, j, T, P, k, nOnesSampling, nZerosSampling,
nOnesAuxi, nZerosAuxi, rho);
/* We refine the parameters for the i-th row of V */
refineRowVPositive(mPostU, vPostU, mPostV, vPostV,
vPriorVj, vPriorVh, mPriorV, &mPred, &vPred,
i, j, T, P, k, nOnesSampling, nZerosSampling,
nOnesAuxj, nZerosAuxj, rho);
/* We refine the global bias parameter */
refineBiasPositive(mPostB, vPostB, vPriorB, mPriorB,
mPred, vPred, T, rho, nOnesSampling);
} else {
/* We sample the row and column of a negative entry */
sampleNegativeEntry(jM, pM, T, P, nZerosSampling,
&i, &j);
/* We compute the predictive mean and variance */
mPred = 0;
vPred = 0;
for (h = 0 ; h < k ; h++) {
mPred += mPostU[ i + h * T ] *
mPostV[ j + h * P ];
vPred += mPostU[ i + h * T ] *
mPostU[ i + h * T ] *
vPostV[ j + h * P ] +
vPostU[ i + h * T ] *
mPostV[ j + h * P ] *
mPostV[ j + h * P ] +
vPostU[ i + h * T ] *
vPostV[ j + h * P ];
}
mPred += *mPostB;
vPred += *vPostB;
/* We refine the parameters for the i-th row of U */
refineRowUNegative(mPostU, vPostU, mPostV, vPostV,
vPriorUi, vPriorUh, mPriorU, &mPred, &vPred,
i, j, T, P, k, e0, nOnesSampling,
nZerosSampling, nOnesAuxi, nZerosAuxi, rho);
/* We refine the parameters for the i-th row of V */
refineRowVNegative(mPostU, vPostU, mPostV, vPostV,
vPriorVj, vPriorVh, mPriorV, &mPred, &vPred,
i, j, T, P, k, e0, nOnesSampling,
nZerosSampling, nOnesAuxj, nZerosAuxj, rho);
/* We refine the global bias parameter */
refineBiasNegative(mPostB, vPostB, vPriorB, mPriorB,
mPred, vPred, T, rho, nZerosSampling, e0);
}
if (iter % 100000 == 0) {
fprintf(stdout, "%d\n", iter);
fflush(stdout);
}
}
/* We write out the random number generator seed */
PutRNGstate();
/* We free memory */
return R_m;
}
void arsaRaw(arsaRawArgs& args)
{
long n = args.n;
Rbyte* rawDist = args.rawDist;
std::vector<double>& levels = args.levels;
double cool = args.cool;
double temperatureMin = args.temperatureMin;
if(temperatureMin <= 0)
{
throw std::runtime_error("Input temperatureMin must be positive");
}
long nReps = args.nReps;
std::vector<int>& permutation = args.permutation;
std::function<void(unsigned long, unsigned long)> progressFunction = args.progressFunction;
bool randomStart = args.randomStart;
int maxMove = args.maxMove;
if(maxMove < 0)
{
throw std::runtime_error("Input maxMove must be non-negative");
}
double effortMultiplier = args.effortMultiplier;
if(effortMultiplier <= 0)
{
throw std::runtime_error("Input effortMultiplier must be positive");
}
permutation.resize(n);
if(n == 1)
{
permutation[0] = 0;
return;
}
else if(n < 1)
{
throw std::runtime_error("Input n must be positive");
}
//We skip the initialisation of D, R1 and R2 from arsa.f, and the computation of asum.
//Next the original arsa.f code creates nReps random permutations, and holds them all at once. This doesn't seem necessary, we create them one at a time and discard them
double zbestAllReps = -std::numeric_limits<double>::infinity();
//A copy of the best permutation found
std::vector<int> bestPermutationThisRep(n);
//We use this to build the random permutations
std::vector<int> consecutive(n);
for(R_xlen_t i = 0; i < n; i++) consecutive[i] = (int)i;
std::vector<int> deltaComponents(levels.size());
//We're doing lots of simulation, so we use the old-fashioned approach to dealing with Rs random number generation
GetRNGstate();
for(int repCounter = 0; repCounter < nReps; repCounter++)
{
//create the random permutation, if we decided to use a random initial permutation
if(randomStart)
{
for(R_xlen_t i = 0; i < n; i++)
{
double rand = unif_rand();
R_xlen_t index = (R_xlen_t)(rand*(n-i));
if(index == n-i) index--;
bestPermutationThisRep[i] = consecutive[index];
std::swap(consecutive[index], *(consecutive.rbegin()+i));
}
}
else
{
for(R_xlen_t i = 0; i < n; i++)
{
bestPermutationThisRep[i] = consecutive[i];
}
}
//calculate value of z
double z = 0;
for(R_xlen_t i = 0; i < n-1; i++)
{
R_xlen_t k = bestPermutationThisRep[i];
for(R_xlen_t j = i+1; j < n; j++)
{
R_xlen_t l = bestPermutationThisRep[j];
z += (j-i) * levels[rawDist[l*n + k]];
}
}
double zbestThisRep = z;
double temperatureMax = 0;
//Now try 5000 random swaps
for(R_xlen_t swapCounter = 0; swapCounter < (R_xlen_t)(5000*effortMultiplier); swapCounter++)
{
R_xlen_t swap1, swap2;
getPairForSwap(n, swap1, swap2);
double delta = computeDelta(bestPermutationThisRep, swap1, swap2, rawDist, levels, deltaComponents);
if(delta < 0)
{
if(fabs(delta) > temperatureMax) temperatureMax = fabs(delta);
}
}
double temperature = temperatureMax;
std::vector<int> currentPermutation = bestPermutationThisRep;
int nloop = (int)((log(temperatureMin) - log(temperatureMax)) / log(cool));
long totalSteps = (long)(nloop * 100 * n * effortMultiplier);
long done = 0;
long threadZeroCounter = 0;
//Rcpp::Rcout << "Steps needed: " << nloop << std::endl;
for(R_xlen_t idk = 0; idk < nloop; idk++)
{
//Rcpp::Rcout << "Temp = " << temperature << std::endl;
for(R_xlen_t k = 0; k < (R_xlen_t)(100*n*effortMultiplier); k++)
{
R_xlen_t swap1, swap2;
//swap
if(unif_rand() <= 0.5)
{
getPairForSwap(n, swap1, swap2);
double delta = computeDelta(currentPermutation, swap1, swap2, rawDist, levels, deltaComponents);
if(delta > -1e-8)
{
z += delta;
std::swap(currentPermutation[swap1], currentPermutation[swap2]);
if(z > zbestThisRep)
{
zbestThisRep = z;
bestPermutationThisRep = currentPermutation;
}
}
else
{
if(unif_rand() <= exp(delta / temperature))
{
z += delta;
std::swap(currentPermutation[swap1], currentPermutation[swap2]);
}
}
}
//insertion
else
{
getPairForMove(n, swap1, swap2, maxMove);
double delta = computeMoveDelta(deltaComponents, swap1, swap2, currentPermutation, rawDist, n, levels);
int permutedSwap1 = currentPermutation[swap1];
if(delta > -1e-8 || unif_rand() <= exp(delta / temperature))
{
z += delta;
if(swap2 > swap1)
{
for(R_xlen_t i = swap1; i < swap2; i++)
{
currentPermutation[i] = currentPermutation[i+1];
}
currentPermutation[swap2] = (int)permutedSwap1;
}
else
{
for(R_xlen_t i = swap1; i > swap2; i--)
{
currentPermutation[i] = currentPermutation[i-1];
}
currentPermutation[swap2] = (int)permutedSwap1;
}
}
if(delta > -1e-8 && z > zbestThisRep)
{
bestPermutationThisRep = currentPermutation;
zbestThisRep = z;
}
}
done++;
threadZeroCounter++;
if(threadZeroCounter % 100 == 0)
{
progressFunction(done, totalSteps);
}
}
temperature *= cool;
}
if(zbestThisRep > zbestAllReps)
{
zbestAllReps = zbestThisRep;
permutation.swap(bestPermutationThisRep);
}
}
PutRNGstate();
}
void regRF(double *x, double *y, int *xdim, int *sampsize,
int *nthsize, int *nrnodes, int *nTree, int *mtry, int *imp,
int *cat, int maxcat, int *jprint, int doProx, int oobprox,
int biasCorr, double *yptr, double *errimp, double *impmat,
double *impSD, double *prox, int *treeSize, SMALL_INT *nodestatus,
int *lDaughter, int *rDaughter, double *avnode, int *mbest,
double *upper, double *mse, const int *keepf, int *replace,
int testdat, double *xts, int *nts, double *yts, int labelts,
double *yTestPred, double *proxts, double *msets, double *coef,
int *nout, int *inbag) {
/*************************************************************************
* Input:
* mdim=number of variables in data set
* nsample=number of cases
*
* nthsize=number of cases in a node below which the tree will not split,
* setting nthsize=5 generally gives good results.
*
* nTree=number of trees in run. 200-500 gives pretty good results
*
* mtry=number of variables to pick to split on at each node. mdim/3
* seems to give genrally good performance, but it can be
* altered up or down
*
* imp=1 turns on variable importance. This is computed for the
* mth variable as the percent rise in the test set mean sum-of-
* squared errors when the mth variable is randomly permuted.
*
*************************************************************************/
//PRINTF( "*jprint: %d\n", *jprint );
//mexEvalString( "pause(0.0001)" );
double errts = 0.0, averrb, meanY, meanYts, varY, varYts, r, xrand,
errb = 0.0, resid=0.0, ooberr, ooberrperm, delta, *resOOB;
double *yb, *xtmp, *xb, *ytr, *ytree = NULL, *tgini;
int k, m, mr, n, nOOB, j, jout, idx, ntest, last, ktmp, nPerm,
nsample, mdim, keepF, keepInbag;
int *oobpair, varImp, localImp, *varUsed;
int *in, *nind, *nodex, *nodexts = NULL;
//Abhi:temp variable
double tmp_d = 0;
int tmp_i;
SMALL_INT tmp_c;
//Do initialization for COKUS's Random generator
seedMT(2*rand()+1); //works well with odd number so why don't use that
nsample = xdim[0];
mdim = xdim[1];
ntest = *nts;
varImp = imp[0];
localImp = imp[1];
nPerm = imp[2]; //PRINTF("nPerm %d\n",nPerm);
keepF = keepf[0];
keepInbag = keepf[1];
if (*jprint == 0) *jprint = *nTree + 1;
yb = (double *) calloc(*sampsize, sizeof(double));
xb = (double *) calloc(mdim * *sampsize, sizeof(double));
ytr = (double *) calloc(nsample, sizeof(double));
xtmp = (double *) calloc(nsample, sizeof(double));
resOOB = (double *) calloc(nsample, sizeof(double));
in = (int *) calloc(nsample, sizeof(int));
nodex = (int *) calloc(nsample, sizeof(int));
varUsed = (int *) calloc(mdim, sizeof(int));
nind = *replace ? NULL : (int *) calloc(nsample, sizeof(int));
if (testdat) {
ytree = (double *) calloc(ntest, sizeof(double));
nodexts = (int *) calloc(ntest, sizeof(int));
}
oobpair = (doProx && oobprox) ?
(int *) calloc(nsample * nsample, sizeof(int)) : NULL;
/* If variable importance is requested, tgini points to the second
"column" of errimp, otherwise it's just the same as errimp. */
tgini = varImp ? errimp + mdim : errimp;
averrb = 0.0;
meanY = 0.0;
varY = 0.0;
zeroDouble(yptr, nsample);
zeroInt(nout, nsample);
for (n = 0; n < nsample; ++n) {
varY += n * (y[n] - meanY)*(y[n] - meanY) / (n + 1);
meanY = (n * meanY + y[n]) / (n + 1);
}
varY /= nsample;
varYts = 0.0;
meanYts = 0.0;
if (testdat) {
for (n = 0; n < ntest; ++n) {
varYts += n * (yts[n] - meanYts)*(yts[n] - meanYts) / (n + 1);
meanYts = (n * meanYts + yts[n]) / (n + 1);
}
varYts /= ntest;
}
if (doProx) {
zeroDouble(prox, nsample * nsample);
if (testdat) zeroDouble(proxts, ntest * (nsample + ntest));
}
if (varImp) {
zeroDouble(errimp, mdim * 2);
if (localImp) zeroDouble(impmat, nsample * mdim);
} else {
zeroDouble(errimp, mdim);
}
if (labelts) zeroDouble(yTestPred, ntest);
/* print header for running output */
if (*jprint <= *nTree) {
PRINTF(" | Out-of-bag ");
if (testdat) PRINTF("| Test set ");
PRINTF("|\n");
PRINTF("Tree | MSE %%Var(y) ");
if (testdat) PRINTF("| MSE %%Var(y) ");
PRINTF("|\n");
// mexEvalString( "pause(0.001)" );
}
GetRNGstate();
/*************************************
* Start the loop over trees.
*************************************/
for (j = 0; j < *nTree; ++j) {
//PRINTF("tree num %d\n",j);fflush(stdout);
//PRINTF("1. maxcat %d, jprint %d, doProx %d, oobProx %d, biasCorr %d\n", *maxcat, *jprint, doProx, oobprox, biasCorr);
idx = keepF ? j * *nrnodes : 0;
zeroInt(in, nsample);
zeroInt(varUsed, mdim);
/* Draw a random sample for growing a tree. */
// PRINTF("1.8. maxcat %d, jprint %d, doProx %d, oobProx %d, biasCorr %d testdat %d\n", maxcat, *jprint, doProx, oobprox, biasCorr,testdat);
if (*replace) { /* sampling with replacement */
for (n = 0; n < *sampsize; ++n) {
xrand = unif_rand();
k = (int)(xrand * nsample);
in[k] = 1;
yb[n] = y[k];
for(m = 0; m < mdim; ++m) {
xb[m + n * mdim] = x[m + k * mdim];
}
}
} else { /* sampling w/o replacement */
for (n = 0; n < nsample; ++n) nind[n] = n;
last = nsample - 1;
for (n = 0; n < *sampsize; ++n) {
ktmp = (int) (unif_rand() * (last+1));
k = nind[ktmp];
swapInt(nind[ktmp], nind[last]);
last--;
in[k] = 1;
yb[n] = y[k];
for(m = 0; m < mdim; ++m) {
xb[m + n * mdim] = x[m + k * mdim];
}
}
}
if (keepInbag) {
for (n = 0; n < nsample; ++n) inbag[n + j * nsample] = in[n];
}
// PRINTF("1.9. maxcat %d, jprint %d, doProx %d, oobProx %d, biasCorr %d testdat %d\n", maxcat, *jprint, doProx, oobprox, biasCorr,testdat);
/* grow the regression tree */
regTree(xb, yb, mdim, *sampsize, lDaughter + idx, rDaughter + idx,
upper + idx, avnode + idx, nodestatus + idx, *nrnodes,
treeSize + j, *nthsize, *mtry, mbest + idx, cat, tgini,
varUsed);
/* predict the OOB data with the current tree */
/* ytr is the prediction on OOB data by the current tree */
// PRINTF("2. maxcat %d, jprint %d, doProx %d, oobProx %d, biasCorr %d testdat %d\n", maxcat, *jprint, doProx, oobprox, biasCorr,testdat);
predictRegTree(x, nsample, mdim, lDaughter + idx,
rDaughter + idx, nodestatus + idx, ytr, upper + idx,
avnode + idx, mbest + idx, treeSize[j], cat, maxcat,
nodex);
/* yptr is the aggregated prediction by all trees grown so far */
errb = 0.0;
ooberr = 0.0;
jout = 0; /* jout is the number of cases that has been OOB so far */
nOOB = 0; /* nOOB is the number of OOB samples for this tree */
for (n = 0; n < nsample; ++n) {
if (in[n] == 0) {
nout[n]++;
nOOB++;
yptr[n] = ((nout[n]-1) * yptr[n] + ytr[n]) / nout[n];
resOOB[n] = ytr[n] - y[n];
ooberr += resOOB[n] * resOOB[n];
}
if (nout[n]) {
jout++;
errb += (y[n] - yptr[n]) * (y[n] - yptr[n]);
}
}
errb /= jout;
/* Do simple linear regression of y on yhat for bias correction. */
if (biasCorr) simpleLinReg(nsample, yptr, y, coef, &errb, nout);
//PRINTF("2.5.maxcat %d, jprint %d, doProx %d, oobProx %d, biasCorr %d\n", maxcat, *jprint, doProx, oobprox, biasCorr);
/* predict testset data with the current tree */
if (testdat) {
predictRegTree(xts, ntest, mdim, lDaughter + idx,
rDaughter + idx, nodestatus + idx, ytree,
upper + idx, avnode + idx,
mbest + idx, treeSize[j], cat, maxcat, nodexts);
/* ytree is the prediction for test data by the current tree */
/* yTestPred is the average prediction by all trees grown so far */
errts = 0.0;
for (n = 0; n < ntest; ++n) {
yTestPred[n] = (j * yTestPred[n] + ytree[n]) / (j + 1);
}
/* compute testset MSE */
if (labelts) {
for (n = 0; n < ntest; ++n) {
resid = biasCorr ?
yts[n] - (coef[0] + coef[1]*yTestPred[n]) :
yts[n] - yTestPred[n];
errts += resid * resid;
}
errts /= ntest;
}
}
//PRINTF("2.6.maxcat %d, jprint %d, doProx %d, oobProx %d, biasCorr %d, testdat %d\n", maxcat, *jprint, doProx, oobprox, biasCorr,testdat);
/* Print running output. */
if ((j + 1) % *jprint == 0) {
PRINTF("%4d |", j + 1);
PRINTF(" %8.4g %8.2f ", errb, 100 * errb / varY);
if(labelts == 1) PRINTF("| %8.4g %8.2f ",
errts, 100.0 * errts / varYts);
PRINTF("|\n");
fflush(stdout);
// mexEvalString("pause(.001);"); // to dump string.
}
//PRINTF("2.7.maxcat %d, jprint %d, doProx %d, oobProx %d, biasCorr %d, testdat %d\n", maxcat, *jprint, doProx, oobprox, biasCorr,testdat);
mse[j] = errb;
if (labelts) msets[j] = errts;
//PRINTF("2.701 j %d, nTree %d, errts %f errb %f \n", j, *nTree, errts,errb);
//PRINTF("2.71.maxcat %d, jprint %d, doProx %d, oobProx %d, biasCorr %d, testdat %d\n", maxcat, *jprint, doProx, oobprox, biasCorr,testdat);
/* DO PROXIMITIES */
if (doProx) {
computeProximity(prox, oobprox, nodex, in, oobpair, nsample);
/* proximity for test data */
if (testdat) {
/* In the next call, in and oobpair are not used. */
computeProximity(proxts, 0, nodexts, in, oobpair, ntest);
for (n = 0; n < ntest; ++n) {
for (k = 0; k < nsample; ++k) {
if (nodexts[n] == nodex[k]) {
proxts[n + ntest * (k+ntest)] += 1.0;
}
}
}
}
}
//PRINTF("2.8.maxcat %d, jprint %d, doProx %d, oobProx %d, biasCorr %d, testdat %d\n", maxcat, *jprint, doProx, oobprox, biasCorr,testdat);
/* Variable importance */
if (varImp) {
for (mr = 0; mr < mdim; ++mr) {
if (varUsed[mr]) { /* Go ahead if the variable is used */
/* make a copy of the m-th variable into xtmp */
for (n = 0; n < nsample; ++n)
xtmp[n] = x[mr + n * mdim];
ooberrperm = 0.0;
for (k = 0; k < nPerm; ++k) {
permuteOOB(mr, x, in, nsample, mdim);
predictRegTree(x, nsample, mdim, lDaughter + idx,
rDaughter + idx, nodestatus + idx, ytr,
upper + idx, avnode + idx, mbest + idx,
treeSize[j], cat, maxcat, nodex);
for (n = 0; n < nsample; ++n) {
if (in[n] == 0) {
r = ytr[n] - y[n];
ooberrperm += r * r;
if (localImp) {
impmat[mr + n * mdim] +=
(r*r - resOOB[n]*resOOB[n]) / nPerm;
}
}
}
}
delta = (ooberrperm / nPerm - ooberr) / nOOB;
errimp[mr] += delta;
impSD[mr] += delta * delta;
/* copy original data back */
for (n = 0; n < nsample; ++n)
x[mr + n * mdim] = xtmp[n];
}
}
}
// PRINTF("3. maxcat %d, jprint %d, doProx %d, oobProx %d, biasCorr %d testdat %d\n", maxcat, *jprint, doProx, oobprox, biasCorr,testdat);
}
PutRNGstate();
/* end of tree iterations=======================================*/
if (biasCorr) { /* bias correction for predicted values */
for (n = 0; n < nsample; ++n) {
if (nout[n]) yptr[n] = coef[0] + coef[1] * yptr[n];
}
if (testdat) {
for (n = 0; n < ntest; ++n) {
yTestPred[n] = coef[0] + coef[1] * yTestPred[n];
}
}
}
if (doProx) {
for (n = 0; n < nsample; ++n) {
for (k = n + 1; k < nsample; ++k) {
prox[nsample*k + n] /= oobprox ?
(oobpair[nsample*k + n] > 0 ? oobpair[nsample*k + n] : 1) :
*nTree;
prox[nsample * n + k] = prox[nsample * k + n];
}
prox[nsample * n + n] = 1.0;
}
if (testdat) {
for (n = 0; n < ntest; ++n)
for (k = 0; k < ntest + nsample; ++k)
proxts[ntest*k + n] /= *nTree;
}
}
if (varImp) {
for (m = 0; m < mdim; ++m) {
errimp[m] = errimp[m] / *nTree;
impSD[m] = sqrt( ((impSD[m] / *nTree) -
(errimp[m] * errimp[m])) / *nTree );
if (localImp) {
for (n = 0; n < nsample; ++n) {
impmat[m + n * mdim] /= nout[n];
}
}
}
}
for (m = 0; m < mdim; ++m) tgini[m] /= *nTree;
//addition by abhi
//in order to release the space stored by the variable in findBestSplit
// call by setting
in_findBestSplit=-99;
findBestSplit(&tmp_d, &tmp_i, &tmp_d, tmp_i, tmp_i,
tmp_i, tmp_i, &tmp_i, &tmp_d,
&tmp_d, &tmp_i, &tmp_i, tmp_i,
tmp_d, tmp_i, &tmp_i);
//do the same freeing of space by calling with -99
in_regTree=-99;
regTree(&tmp_d, &tmp_d, tmp_i, tmp_i, &tmp_i,
&tmp_i,
&tmp_d, &tmp_d, &tmp_c, tmp_i,
&tmp_i, tmp_i, tmp_i, &tmp_i, &tmp_i,
&tmp_d, &tmp_i);
free(yb);
free(xb);
free(ytr);
free(xtmp);
free(resOOB);
free(in);
free(nodex);
free(varUsed);
if (!(*replace) )
free(nind);
if (testdat) {
free(ytree);
free(nodexts);
}
if (doProx && oobprox)
free(oobpair) ;
}
void sim_geno(int n_ind, int n_pos, int n_gen, int n_draws,
int *geno, double *rf, double *rf2,
double error_prob, int *draws,
double initf(int),
double emitf(int, int, double),
double stepf(int, int, double, double))
{
int i, k, j, v, v2;
double s, **beta, *probs;
int **Geno, ***Draws, curstate;
/* allocate space for beta and
reorganize geno and draws */
/* Geno indexed as Geno[pos][ind] */
/* Draws indexed as Draws[rep][pos][ind] */
reorg_geno(n_ind, n_pos, geno, &Geno);
reorg_draws(n_ind, n_pos, n_draws, draws, &Draws);
allocate_alpha(n_pos, n_gen, &beta);
allocate_double(n_gen, &probs);
/* Read R's random seed */
GetRNGstate();
for(i=0; i<n_ind; i++) { /* i = individual */
R_CheckUserInterrupt(); /* check for ^C */
/* do backward equations */
/* initialize beta */
for(v=0; v<n_gen; v++) beta[v][n_pos-1] = 0.0;
/* backward equations */
for(j=n_pos-2; j>=0; j--) {
for(v=0; v<n_gen; v++) {
beta[v][j] = beta[0][j+1] + stepf(v+1,1,rf[j], rf2[j]) +
emitf(Geno[j+1][i],1,error_prob);
for(v2=1; v2<n_gen; v2++)
beta[v][j] = addlog(beta[v][j], beta[v2][j+1] +
stepf(v+1,v2+1,rf[j],rf2[j]) +
emitf(Geno[j+1][i],v2+1,error_prob));
}
}
for(k=0; k<n_draws; k++) { /* k = simulation replicate */
/* first draw */
/* calculate probs */
s = (probs[0] = initf(1)+emitf(Geno[0][i],1,error_prob)+beta[0][0]);
for(v=1; v<n_gen; v++) {
probs[v] = initf(v+1) + emitf(Geno[0][i], v+1, error_prob) +
beta[v][0];
s = addlog(s, probs[v]);
}
for(v=0; v<n_gen; v++) probs[v] = exp(probs[v] - s);
/* make draw: returns a value from {1, 2, ..., n_gen} */
curstate = Draws[k][0][i] = sample_int(n_gen, probs);
/* move along chromosome */
for(j=1; j<n_pos; j++) {
/* calculate probs */
for(v=0; v<n_gen; v++)
probs[v] = exp(stepf(curstate,v+1,rf[j-1],rf2[j-1]) +
emitf(Geno[j][i],v+1,error_prob) +
beta[v][j] - beta[curstate-1][j-1]);
/* make draw */
curstate = Draws[k][j][i] = sample_int(n_gen, probs);
}
} /* loop over replicates */
} /* loop over individuals */
/* write R's random seed */
PutRNGstate();
}
// The programme for GIBBS SAMPLING with XB and missing values
void GIBBS_gp(double *flag, int *its, int *burnin,
int *n, int *T, int *r, int *rT, int *p, int *N, int *report,
int *cov, int *spdecay, double *shape_e, double *shape_eta,
double *phi_a, double *phi_b,
double *prior_a, double *prior_b, double *prior_mubeta,
double *prior_sigbeta, double *prior_omu, double *prior_osig,
double *phi, double *tau, double *phis, int *phik,
double *d, double *sig_e, double *sig_eta,
double *beta, double *X, double *z, double *o, int *constant,
double *phipf, double *accept, double *nupf, double *sig_epf,
double *sig_etapf, double *betapf, double *opf, double *zlt_mean_sd,
double *gof, double *penalty)
{
// unsigned iseed = 44;
// srand(iseed);
int its1, brin, col, i, j, p1, N1, rep1;
double *phip, *sig_ep, *sig_etap, *betap, *op;
double *phi1, *sig_e1, *sig_eta1, *beta1, *o1;
double *z1, *oo, *ot, *acc;
its1 = *its;
brin = *burnin;
col = *constant;
// n1 = *n;
// r1 = *r;
p1 = *p;
N1 = *N;
// nr = n1 * r1;
rep1 = *report;
double accept1, mn_rep[N1], var_rep[N1];
accept1 = 0.0;
for(j=0; j<N1; j++) {
mn_rep[j] = 0.0;
var_rep[j] = 0.0;
}
phip = (double *) malloc((size_t)((col)*sizeof(double)));
sig_ep = (double *) malloc((size_t)((col)*sizeof(double)));
sig_etap = (double *) malloc((size_t)((col)*sizeof(double)));
betap = (double *) malloc((size_t)((p1)*sizeof(double)));
op = (double *) malloc((size_t)((N1)*sizeof(double)));
phi1 = (double *) malloc((size_t)((col)*sizeof(double)));
sig_e1 = (double *) malloc((size_t)((col)*sizeof(double)));
sig_eta1 = (double *) malloc((size_t)((col)*sizeof(double)));
beta1 = (double *) malloc((size_t)((p1)*sizeof(double)));
o1 = (double *) malloc((size_t)((N1)*sizeof(double)));
z1 = (double *) malloc((size_t)((N1)*sizeof(double)));
oo = (double *) malloc((size_t)((col)*sizeof(double)));
ot = (double *) malloc((size_t)((col)*sizeof(double)));
acc = (double *) malloc((size_t)((col)*sizeof(double)));
double *nu, *nup;
nu = (double *) malloc((size_t)((col)*sizeof(double)));
nup = (double *) malloc((size_t)((col)*sizeof(double)));
nu[0] = 0.5;
ext_sige(phi, phi1);
ext_sige(sig_e, sig_e1);
ext_sigeta(sig_eta, sig_eta1);
ext_beta(p, beta, beta1);
ext_o(N, o, o1);
ext_o(N, z, z1);
// for missing
for(j=0; j < N1; j++) {
if (flag[j] == 1.0) {
oo[0]=o1[j];
mvrnormal(constant, oo, sig_e1, constant, ot);
z1[j] = ot[0];
}
else {
z1[j] = z1[j];
}
}
GetRNGstate();
for(i=0; i < its1; i++) {
JOINT_gp(n, T, r, rT, p, N, cov, spdecay, shape_e, shape_eta, phi_a, phi_b,
prior_a, prior_b, prior_mubeta, prior_sigbeta, prior_omu, prior_osig,
phi1, tau, phis, phik, nu, d, sig_e1, sig_eta1, beta1, X, z1, o1, constant,
phip, acc, nup, sig_ep, sig_etap, betap, op);
accept1 += acc[0];
phipf[i] = phip[0];
nupf[i] = nup[0];
sig_epf[i] = sig_ep[0];
sig_etapf[i] = sig_etap[0];
for(j=0; j < p1; j++) {
betapf[j+i*p1] = betap[j];
}
for(j=0; j < N1; j++) {
opf[j+i*N1] = op[j];
}
ext_sige(phip, phi1);
ext_sige(nup, nu);
ext_sige(sig_ep, sig_e1);
ext_sige(sig_etap, sig_eta1);
ext_beta(p, betap, beta1);
// ext_o(N, op, o1);
// for pmcc
for(j=0; j < N1; j++) {
if(i >= brin) {
oo[0] = op[j];
mvrnormal(constant, oo, sig_e1, constant, ot);
mn_rep[j] += ot[0];
var_rep[j] += ot[0]*ot[0];
}
}
// for missing
for(j=0; j < N1; j++) {
if (flag[j] == 1.0) {
oo[0]=op[j];
mvrnormal(constant, oo, sig_e1, constant, ot);
z1[j] = ot[0];
}
else {
z1[j] = z1[j];
}
}
if(cov[0]==4) {
GP_para_printRnu(i, its1, rep1, p1, accept1, phip, nup, sig_ep, sig_etap, betap);
}
else {
GP_para_printR (i, its1, rep1, p1, accept1, phip, sig_ep, sig_etap, betap);
}
} // end of iteration loop
PutRNGstate();
accept[0] = accept1;
double pen, go;
pen = 0;
go =0;
int iit;
iit = 0;
iit = its1-brin;
// fitted zlt, mean and sd
for(j=0; j < N1; j++) {
mn_rep[j] = mn_rep[j]/iit;
var_rep[j] = var_rep[j]/iit;
var_rep[j] = var_rep[j] - mn_rep[j]*mn_rep[j];
zlt_mean_sd[j] = mn_rep[j];
zlt_mean_sd[j+N1] = sqrt(var_rep[j]);
}
// pmcc
for(j=0; j < N1; j++) {
if (flag[j] == 1.0) {
mn_rep[j] = 0.0;
var_rep[j] = 0.0;
}
else {
mn_rep[j] = mn_rep[j];
var_rep[j] = var_rep[j];
mn_rep[j] = (mn_rep[j] - z1[j])*(mn_rep[j] - z1[j]);
}
pen += var_rep[j];
go += mn_rep[j];
}
gof[0] = go;
penalty[0] = pen;
free(phip);
free(nu);
free(nup);
free(sig_ep);
free(sig_etap);
free(betap);
free(op);
free(phi1);
free(sig_e1);
free(sig_eta1);
free(beta1);
free(o1);
free(z1);
free(oo);
free(ot);
free(acc);
return;
}
SEXP sampler_glue_R_dist(SEXP sampler, SEXP sampler_context, SEXP log_dens,
SEXP x0, SEXP sample_size, SEXP tuning, SEXP envir) {
// Check parameters for validity and unpack some of them into C types.
if (!isEnvironment(envir))
error("envir is not an environment.");
int sample_size_int = asInteger(sample_size);
if (sample_size_int<1)
error("sample size must be a positive integer.");
int ndim = length(x0);
double tuning_dbl = asReal(tuning);
double *x0_dbl = REAL(x0);
// Locate the sampler as a function pointer.
if (!isString(sampler))
error("sampler is not a character string.");
sampler_t *sampler_fp =
(sampler_t*)R_FindSymbol(CHAR(STRING_ELT(sampler,0)), "", NULL);
if (sampler_fp==NULL)
error("Cannot locate symbol \"%s\".", CHAR(STRING_ELT(sampler,0)));
// Create a stub for log_dens so that it looks like a C density
// to the sampler.
R_stub_context_t stub_context =
{ .log_dens=log_dens, .envir=envir, .evals=0, .grads=0 };
SEXP raw_context;
PROTECT(raw_context = void_as_raw(&stub_context));
dist_t stub_ds = { .log_dens=R_log_density_stub_func,
.context=raw_context, .ndim=ndim };
// Allocate a result matrix, set up the RNG, and call the sampler
// to draw a sample.
SEXP X_out;
PROTECT(X_out = allocMatrix(REALSXP, sample_size_int, ndim));
GetRNGstate();
sampler_fp(sampler_context, &stub_ds, x0_dbl, sample_size_int,
tuning_dbl, REAL(X_out));
PutRNGstate();
// Set up return value as an R object.
SEXP ans, ans_names;
PROTECT(ans = allocVector(VECSXP, 3));
SET_VECTOR_ELT(ans, 0, X_out);
SET_VECTOR_ELT(ans, 1, ScalarInteger(stub_context.evals));
SET_VECTOR_ELT(ans, 2, ScalarInteger(stub_context.grads));
PROTECT(ans_names = allocVector(VECSXP, 3));
SET_VECTOR_ELT(ans_names, 0, mkString("X"));
SET_VECTOR_ELT(ans_names, 1, mkString("evals"));
SET_VECTOR_ELT(ans_names, 2, mkString("grads"));
setAttrib(ans, R_NamesSymbol, ans_names);
UNPROTECT(4);
return(ans);
}
// This function wraps an R log density function so that it exposes
// the interface expected by a sampler_t and keeps track of the number
// of times it is called.
static double R_log_density_stub_func(dist_t *ds, double *x,
int compute_grad, double *grad) {
SEXP xsexp, fcall, result_sexp, compute_grad_sexp, result_names;
R_stub_context_t *stub_context = (R_stub_context_t*)raw_as_void(ds->context);
// Allocate R variables for the arguments to the R log.density.and.grad
// and call it.
PROTECT(xsexp = allocVector(REALSXP, ds->ndim));
memmove(REAL(xsexp), x, sizeof(double)*ds->ndim);
PROTECT(compute_grad_sexp = allocVector(LGLSXP, 1));
LOGICAL(compute_grad_sexp)[0] = (compute_grad!=0);
PROTECT(fcall = lang3(stub_context->log_dens, xsexp, compute_grad_sexp));
PROTECT(result_sexp = eval(fcall, stub_context->envir));
double log_dens = NAN;
int found_log_dens=0, found_grad=0;
// Unpack the results from the log.density.and.grad into the
// variable log_dens and (if appropriate) the memory pointed to by
// grad.
if (!isNewList(result_sexp)) {
error("log density function must return a list.");
}
PROTECT(result_names = getAttrib(result_sexp, R_NamesSymbol));
for (int i = 0; i < length(result_sexp); i++) {
if (!strcmp(CHAR(STRING_ELT(result_names,i)), "log.density")) {
log_dens = asReal(VECTOR_ELT(result_sexp, i));
found_log_dens = 1;
}
if (compute_grad &&
!strcmp(CHAR(STRING_ELT(result_names,i)), "grad.log.density")) {
memmove(grad, REAL(VECTOR_ELT(result_sexp, i)), sizeof(double)*ds->ndim);
found_grad = 1;
}
}
UNPROTECT(5);
// Throw an error if the log density did not return the appropriate
// list elements.
if (!found_log_dens)
error("log density did not return log.density element.");
if (!found_grad && compute_grad)
error("log density did not return grad.log.density element.");
// Increment the evaluation counters.
stub_context->evals++;
if (compute_grad)
stub_context->grads++;
return log_dens;
}
void generate_SNP (double *beta, double *gamma, double *X, double *Y, double *Z,
int n, int p, int s, double sig2, int missing_index, double **exact_missing,
int *row_missing, int *col_missing, int num_missing, double *Zprob,
double *R, int SNPprior)
{
double *Z1, tmp_Y_Xbeta, num[3], p1[3], prior[3], working;
int inc=1, i, three=3, inc2=n;
char notrans='n', trans='t';
i=missing_index;
Z1 = (double *) malloc(sizeof(double) * s);
if (Z1==NULL) {
Rprintf("Malloc failed for Z1\n");
exit(EXIT_FAILURE);
}
F77_CALL(dcopy)(&s, Z+row_missing[i], &n, Z1, &inc);
tmp_Y_Xbeta = *(Y + row_missing[i]) - F77_CALL(ddot)(&p, X + row_missing[i], &n, beta, &inc);
/*If informative priors used, FBLAS */
if(SNPprior==1) {
F77_CALL(dcopy)(&three, Zprob + i, &num_missing, prior, &inc);
*(Z1+col_missing[i])=ALL1;
num[0]= prior[0] * exp(R_pow(tmp_Y_Xbeta - F77_CALL(ddot)(&s, Z1, &inc, gamma, &inc), 2.0)/ (-2 * sig2));
*(Z1+col_missing[i])=ALL2;
num[1]= prior[1] * exp(R_pow(tmp_Y_Xbeta - F77_CALL(ddot)(&s, Z1, &inc, gamma, &inc), 2.0)/ (-2 * sig2));
*(Z1+col_missing[i])=ALL3;
num[2]= prior[2] * exp(R_pow(tmp_Y_Xbeta - F77_CALL(ddot)(&s, Z1, &inc, gamma, &inc), 2.0)/ (-2 * sig2));
}
/*If noninformative priors used, FBLAS */
else {
F77_CALL(dcopy)(&s, Z+row_missing[i], &n, Z1, &inc);
tmp_Y_Xbeta = *(Y + row_missing[i]) - F77_CALL(ddot)(&p, X + row_missing[i], &n, beta, &inc);
*(Z1+col_missing[i])=ALL1;
num[0]= exp(R_pow(tmp_Y_Xbeta - F77_CALL(ddot)(&s, Z1, &inc, gamma, &inc), 2.0)/ (-2 * sig2));
*(Z1+col_missing[i])=ALL2;
num[1]= exp(R_pow(tmp_Y_Xbeta - F77_CALL(ddot)(&s, Z1, &inc, gamma, &inc), 2.0)/ (-2 * sig2));
*(Z1+col_missing[i])=ALL3;
num[2]= exp(R_pow(tmp_Y_Xbeta - F77_CALL(ddot)(&s, Z1, &inc, gamma, &inc), 2.0)/ (-2 * sig2));
}
working=num[0]+num[1]+num[2];
p1[0]=num[0]/working;
p1[1]=num[1]/working;
GetRNGstate();
working = unif_rand();
PutRNGstate();
if(working<=p1[0])
**(exact_missing+i) = ALL1;
else if (working<=(p1[0]+p1[1]))
**(exact_missing+i) = ALL2;
else
**(exact_missing+i) = ALL3;
free(Z1);
}
SEXP spPPGLM(SEXP Y_r, SEXP X_r, SEXP p_r, SEXP n_r, SEXP family_r, SEXP weights_r,
SEXP m_r, SEXP knotsD_r, SEXP knotsCoordsD_r,
SEXP betaPrior_r, SEXP betaNorm_r, SEXP sigmaSqIG_r, SEXP nuUnif_r, SEXP phiUnif_r,
SEXP phiStarting_r, SEXP sigmaSqStarting_r, SEXP nuStarting_r, SEXP betaStarting_r, SEXP w_strStarting_r,
SEXP phiTuning_r, SEXP sigmaSqTuning_r, SEXP nuTuning_r, SEXP betaTuning_r, SEXP w_strTuning_r,
SEXP covModel_r, SEXP nSamples_r, SEXP verbose_r, SEXP nReport_r){
/*****************************************
Common variables
*****************************************/
int i,j,k,l,info,nProtect= 0;
char const *lower = "L";
char const *upper = "U";
char const *ntran = "N";
char const *ytran = "T";
char const *rside = "R";
char const *lside = "L";
const double one = 1.0;
const double negOne = -1.0;
const double zero = 0.0;
const int incOne = 1;
/*****************************************
Set-up
*****************************************/
double *Y = REAL(Y_r);
double *X = REAL(X_r);
int p = INTEGER(p_r)[0];
int pp = p*p;
int n = INTEGER(n_r)[0];
std::string family = CHAR(STRING_ELT(family_r,0));
int *weights = INTEGER(weights_r);
//covariance model
std::string covModel = CHAR(STRING_ELT(covModel_r,0));
int m = INTEGER(m_r)[0];
double *knotsD = REAL(knotsD_r);
double *knotsCoordsD = REAL(knotsCoordsD_r);
//priors and starting
std::string betaPrior = CHAR(STRING_ELT(betaPrior_r,0));
double *betaMu = NULL;
double *betaSd = NULL;
if(betaPrior == "normal"){
betaMu = REAL(VECTOR_ELT(betaNorm_r, 0));
betaSd = REAL(VECTOR_ELT(betaNorm_r, 1));
}
double *sigmaSqIG = REAL(sigmaSqIG_r);
double *phiUnif = REAL(phiUnif_r);
double phiStarting = REAL(phiStarting_r)[0];
double sigmaSqStarting = REAL(sigmaSqStarting_r)[0];
double *betaStarting = REAL(betaStarting_r);
double *w_strStarting = REAL(w_strStarting_r);
double sigmaSqIGa = sigmaSqIG[0]; double sigmaSqIGb = sigmaSqIG[1];
double phiUnifa = phiUnif[0]; double phiUnifb = phiUnif[1];
//if matern
double *nuUnif = NULL;
double nuStarting = 0;
double nuUnifa = 0, nuUnifb = 0;
if(covModel == "matern"){
nuUnif = REAL(nuUnif_r);
nuStarting = REAL(nuStarting_r)[0];
nuUnifa = nuUnif[0]; nuUnifb = nuUnif[1];
}
//tuning
double *betaTuning = (double *) R_alloc(p*p, sizeof(double));
F77_NAME(dcopy)(&pp, REAL(betaTuning_r), &incOne, betaTuning, &incOne);
double phiTuning = sqrt(REAL(phiTuning_r)[0]);
double sigmaSqTuning = sqrt(REAL(sigmaSqTuning_r)[0]);
double *w_strTuning = REAL(w_strTuning_r);
double nuTuning = 0;
if(covModel == "matern")
nuTuning = sqrt(REAL(nuTuning_r)[0]);
int nSamples = INTEGER(nSamples_r)[0];
int verbose = INTEGER(verbose_r)[0];
int nReport = INTEGER(nReport_r)[0];
if(verbose){
Rprintf("----------------------------------------\n");
Rprintf("\tGeneral model description\n");
Rprintf("----------------------------------------\n");
Rprintf("Model fit with %i observations.\n\n", n);
Rprintf("Number of covariates %i (including intercept if specified).\n\n", p);
Rprintf("Using the %s spatial correlation model.\n\n", covModel.c_str());
Rprintf("Using non-modified predictive process with %i knots.\n\n", m);
Rprintf("Number of MCMC samples %i.\n\n", nSamples);
Rprintf("Priors and hyperpriors:\n");
if(betaPrior == "flat"){
Rprintf("\tbeta flat.\n");
}else{
Rprintf("\tbeta normal:\n");
Rprintf("\t\tmu:"); printVec(betaMu, p);
Rprintf("\t\tsd:"); printVec(betaSd, p);Rprintf("\n");
}
Rprintf("\n");
Rprintf("\tsigma.sq IG hyperpriors shape=%.5f and scale=%.5f\n", sigmaSqIGa, sigmaSqIGb);
Rprintf("\n");
Rprintf("\tphi Unif hyperpriors a=%.5f and b=%.5f\n", phiUnifa, phiUnifb);
Rprintf("\n");
if(covModel == "matern"){
Rprintf("\tnu Unif hyperpriors a=%.5f and b=%.5f\n", nuUnifa, nuUnifb);
}
Rprintf("Metropolis tuning values:\n");
Rprintf("\tbeta tuning:\n");
printMtrx(betaTuning, p, p);
Rprintf("\n");
Rprintf("\tsigma.sq tuning: %.5f\n", sigmaSqTuning);
Rprintf("\n");
Rprintf("\tphi tuning: %.5f\n", phiTuning);
Rprintf("\n");
if(covModel == "matern"){
Rprintf("\tnu tuning: %.5f\n", nuTuning);
Rprintf("\n");
}
Rprintf("Metropolis starting values:\n");
Rprintf("\tbeta starting:\n");
Rprintf("\t"); printVec(betaStarting, p);
Rprintf("\n");
Rprintf("\tsigma.sq starting: %.5f\n", sigmaSqStarting);
Rprintf("\n");
Rprintf("\tphi starting: %.5f\n", phiStarting);
Rprintf("\n");
if(covModel == "matern"){
Rprintf("\tnu starting: %.5f\n", nuStarting);
Rprintf("\n");
}
}
/*****************************************
Set-up MCMC sample matrices etc.
*****************************************/
int nn = n*n, nm = n*m, mm = m*m;
//spatial parameters
int nParams, betaIndx, sigmaSqIndx, phiIndx, nuIndx;
if(covModel != "matern"){
nParams = p+2;//sigma^2, phi
betaIndx = 0; sigmaSqIndx = betaIndx+p; phiIndx = sigmaSqIndx+1;
}else{
nParams = p+3;//sigma^2, phi, nu
betaIndx = 0; sigmaSqIndx = betaIndx+p; phiIndx = sigmaSqIndx+1; nuIndx = phiIndx+1;
}
double *spParams = (double *) R_alloc(nParams, sizeof(double));
//set starting
F77_NAME(dcopy)(&p, betaStarting, &incOne, &spParams[betaIndx], &incOne);
spParams[sigmaSqIndx] = log(sigmaSqStarting);
spParams[phiIndx] = logit(phiStarting, phiUnifa, phiUnifb);
if(covModel == "matern")
spParams[nuIndx] = logit(nuStarting, nuUnifa, nuUnifb);
double *wCurrent = (double *) R_alloc(n, sizeof(double));
double *w_strCurrent = (double *) R_alloc(m, sizeof(double));
F77_NAME(dcopy)(&m, w_strStarting, &incOne, w_strCurrent, &incOne);
//samples and random effects
SEXP w_r, w_str_r, samples_r, accept_r;
PROTECT(w_r = allocMatrix(REALSXP, n, nSamples)); nProtect++;
double *w = REAL(w_r); zeros(w, n*nSamples);
PROTECT(w_str_r = allocMatrix(REALSXP, m, nSamples)); nProtect++;
double *w_str = REAL(w_str_r); zeros(w_str, m*nSamples);
PROTECT(samples_r = allocMatrix(REALSXP, nParams, nSamples)); nProtect++;
double *samples = REAL(samples_r);
PROTECT(accept_r = allocMatrix(REALSXP, 1, 1)); nProtect++;
/*****************************************
Set-up MCMC alg. vars. matrices etc.
*****************************************/
int s=0, status=0, rtnStatus=0, accept=0, batchAccept = 0;
double logPostCurrent = 0, logPostCand = 0, detCand = 0;
double *P = (double *) R_alloc(nm, sizeof(double));
double *K = (double *) R_alloc(mm, sizeof(double));
double *tmp_n = (double *) R_alloc(n, sizeof(double));
double *tmp_m = (double *) R_alloc(m, sizeof(double));
double *tmp_nm = (double *) R_alloc(nm, sizeof(double));
double *theta = (double *) R_alloc(3, sizeof(double)); //phi, nu, and perhaps more in the future
double *candSpParams = (double *) R_alloc(nParams, sizeof(double));
double *w_strCand = (double *) R_alloc(m, sizeof(double));
double *wCand = (double *) R_alloc(n, sizeof(double));
double sigmaSq, phi, nu;
double *beta = (double *) R_alloc(p, sizeof(double));
double logMHRatio;
if(verbose){
Rprintf("-------------------------------------------------\n");
Rprintf("\t\tSampling\n");
Rprintf("-------------------------------------------------\n");
#ifdef Win32
R_FlushConsole();
#endif
}
logPostCurrent = R_NegInf;
GetRNGstate();
for(s = 0; s < nSamples; s++){
//propose
mvrnorm(&candSpParams[betaIndx], &spParams[betaIndx], betaTuning, p, false);
F77_NAME(dcopy)(&p, &candSpParams[betaIndx], &incOne, beta, &incOne);
candSpParams[sigmaSqIndx] = rnorm(spParams[sigmaSqIndx], sigmaSqTuning);
sigmaSq = theta[0] = exp(candSpParams[sigmaSqIndx]);
candSpParams[phiIndx] = rnorm(spParams[phiIndx], phiTuning);
phi = theta[1] = logitInv(candSpParams[phiIndx], phiUnifa, phiUnifb);
if(covModel == "matern"){
candSpParams[nuIndx] = rnorm(spParams[nuIndx], nuTuning);
nu = theta[2] = logitInv(candSpParams[nuIndx], nuUnifa, nuUnifb);
}
for(i = 0; i < m; i++){
w_strCand[i] = rnorm(w_strCurrent[i], sqrt(w_strTuning[i]));
}
//construct covariance matrices
spCovLT(knotsD, m, theta, covModel, K);
spCov(knotsCoordsD, nm, theta, covModel, P);
//invert C and log det cov
detCand = 0;
F77_NAME(dpotrf)(lower, &m, K, &m, &info); if(info != 0){error("c++ error: Cholesky failed in spGLM\n");}
for(i = 0; i < m; i++) detCand += 2*log(K[i*m+i]);
F77_NAME(dpotri)(lower, &m, K, &m, &info); if(info != 0){error("c++ error: Cholesky inverse failed in spGLM\n");}
//make \tild{w}
F77_NAME(dsymv)(lower, &m, &one, K, &m, w_strCand, &incOne, &zero, tmp_m, &incOne);
F77_NAME(dgemv)(ytran, &m, &n, &one, P, &m, tmp_m, &incOne, &zero, wCand, &incOne);
//Likelihood with Jacobian
logPostCand = 0.0;
if(betaPrior == "normal"){
for(i = 0; i < p; i++){
logPostCand += dnorm(beta[i], betaMu[i], betaSd[i], 1);
}
}
logPostCand += -1.0*(1.0+sigmaSqIGa)*log(sigmaSq)-sigmaSqIGb/sigmaSq+log(sigmaSq);
logPostCand += log(phi - phiUnifa) + log(phiUnifb - phi);
if(covModel == "matern"){
logPostCand += log(nu - nuUnifa) + log(nuUnifb - nu);
}
F77_NAME(dgemv)(ntran, &n, &p, &one, X, &n, beta, &incOne, &zero, tmp_n, &incOne);
if(family == "binomial"){
logPostCand += binomial_logpost(n, Y, tmp_n, wCand, weights);
}else if(family == "poisson"){
logPostCand += poisson_logpost(n, Y, tmp_n, wCand, weights);
}else{
error("c++ error: family misspecification in spGLM\n");
}
//(-1/2) * tmp_n` * C^-1 * tmp_n
logPostCand += -0.5*detCand-0.5*F77_NAME(ddot)(&m, w_strCand, &incOne, tmp_m, &incOne);
//
//MH accept/reject
//
//MH ratio with adjustment
logMHRatio = logPostCand - logPostCurrent;
if(runif(0.0,1.0) <= exp(logMHRatio)){
F77_NAME(dcopy)(&nParams, candSpParams, &incOne, spParams, &incOne);
F77_NAME(dcopy)(&n, wCand, &incOne, wCurrent, &incOne);
F77_NAME(dcopy)(&m, w_strCand, &incOne, w_strCurrent, &incOne);
logPostCurrent = logPostCand;
accept++;
batchAccept++;
}
/******************************
Save samples and report
*******************************/
F77_NAME(dcopy)(&nParams, spParams, &incOne, &samples[s*nParams], &incOne);
F77_NAME(dcopy)(&n, wCurrent, &incOne, &w[s*n], &incOne);
F77_NAME(dcopy)(&m, w_strCurrent, &incOne, &w_str[s*m], &incOne);
//report
if(verbose){
if(status == nReport){
Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples);
Rprintf("Report interval Metrop. Acceptance rate: %3.2f%%\n", 100.0*batchAccept/nReport);
Rprintf("Overall Metrop. Acceptance rate: %3.2f%%\n", 100.0*accept/s);
Rprintf("-------------------------------------------------\n");
#ifdef Win32
R_FlushConsole();
#endif
status = 0;
batchAccept = 0;
}
}
status++;
R_CheckUserInterrupt();
}//end sample loop
PutRNGstate();
//final status report
if(verbose){
Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples);
Rprintf("-------------------------------------------------\n");
#ifdef Win32
R_FlushConsole();
#endif
}
//untransform variance variables
for(s = 0; s < nSamples; s++){
samples[s*nParams+sigmaSqIndx] = exp(samples[s*nParams+sigmaSqIndx]);
samples[s*nParams+phiIndx] = logitInv(samples[s*nParams+phiIndx], phiUnifa, phiUnifb);
if(covModel == "matern")
samples[s*nParams+nuIndx] = logitInv(samples[s*nParams+nuIndx], nuUnifa, nuUnifb);
}
//calculate acceptance rate
REAL(accept_r)[0] = 100.0*accept/s;
//make return object
SEXP result, resultNames;
int nResultListObjs = 4;
PROTECT(result = allocVector(VECSXP, nResultListObjs)); nProtect++;
PROTECT(resultNames = allocVector(VECSXP, nResultListObjs)); nProtect++;
//samples
SET_VECTOR_ELT(result, 0, samples_r);
SET_VECTOR_ELT(resultNames, 0, mkChar("p.beta.theta.samples"));
SET_VECTOR_ELT(result, 1, accept_r);
SET_VECTOR_ELT(resultNames, 1, mkChar("acceptance"));
SET_VECTOR_ELT(result, 2, w_r);
SET_VECTOR_ELT(resultNames, 2, mkChar("p.w.samples"));
SET_VECTOR_ELT(result, 3, w_str_r);
SET_VECTOR_ELT(resultNames, 3, mkChar("p.w.knots.samples"));
namesgets(result, resultNames);
//unprotect
UNPROTECT(nProtect);
return(result);
}
void maximinLHS_C(int* N, int* K, int* DUP, int* result, int* avail,
int* point1, int* list1, int* vec)
{
/* distance between corner (1,1,1,..) and (N,N,N,...) */
double corners = sqrt((double) *K * (*N - 1) * (*N - 1));
/* iterators */
int row, col;
int count;
int j, k;
/* index of the current candidate point */
int point_index;
/* index of the optimum point */
int best;
/* the squared distance between points */
unsigned int distSquared;
/*
* the minimum distance between points
*/
double max_all;
/* The minumum candidate squared difference between points */
unsigned int min_candidate;
/* the length of the point1 columns and the list1 vector */
int len = *DUP * (*N - 1);
/* used in testing the output */
int total;
int test = 1;
/* initialize the avail matrix */
for(row = 0; row < *K; row++)
{
for(col = 0; col < *N; col++)
{
avail[row * (*N) + col] = col + 1;
}
}
/*
* come up with an array of K integers from 1 to N randomly
* and put them in the last column of result
*/
GetRNGstate();
for(row = 0; row < *K; row++)
{
result[row * (*N) + ((*N) - 1)] = (int) floor(unif_rand() * (*N) + 1);
}
/*
* use the random integers from the last column of result to place an N value
* randomly through the avail matrix
*/
for(row = 0; row < *K; row++)
{
avail[row * (*N) + (result[row * (*N) + ((*N) - 1)] - 1)] = *N;
}
/* move backwards through the result matrix columns */
for(count = (*N - 1); count > 0; count--)
{
for(row = 0; row < *K; row++)
{
for(col = 0; col < *DUP; col++)
{
/* create the list1 vector */
for(j = 0; j < count; j++)
{
list1[(j + count*col)] = avail[row * (*N) + j];
}
}
/* create a set of points to choose from */
for(col = (count * (*DUP)); col > 0; col--)
{
point_index = (int) floor(unif_rand() * col + 1);
point1[row * len + (col-1)] = list1[point_index];
list1[point_index] = list1[(col-1)];
}
}
max_all = DBL_MIN;
best = 0;
for(col = 0; col < ((*DUP) * count - 1); col++)
{
min_candidate = corners;
for(j = count; j < *N; j++)
{
distSquared = 0;
/*
* find the distance between candidate points and the points already
* in the sample
*/
for(k = 0; k < *K; k++)
{
vec[k] = point1[k * len + col] - result[k * (*N) + j];
distSquared += vec[k] * vec[k];
}
/*
* if the distSquard value is the smallest so far place it in
* min candidate
*/
if(min_candidate > distSquared) min_candidate = distSquared;
}
/*
* if the difference between min candidate and OPT2 is the smallest so
* far, then keep that point as the best.
*/
if(min_candidate > max_all)
{
max_all = min_candidate;
best = col;
}
}
/* take the best point out of point1 and place it in the result */
for(row = 0; row < *K; row++){
result[row * (*N) + (count-1)] = point1[row * len + best];
}
/* update the numbers that are available for the future points */
for(row = 0; row < *K; row++)
{
for(col = 0; col < *N; col++)
{
if(avail[row * (*N) + col]==result[row * (*N) + (count-1)])
{
avail[row * (*N) + col] = avail[row * (*N) + (count-1)];
}
}
}
}
/*
* once all but the last points of result are filled in, there is only
* one choice left
*/
for(row = 0; row < *K; row++)
{
result[row * (*N) + 0] = avail[row * (*N) + 0];
}
/*
* verify that the result is a latin hypercube. One easy check is to ensure
* that the sum of the rows is the sum of the 1st N integers. This check can
* be fooled in one unlikely way...
* if a column should be 1 2 3 4 6 8 5 7 9 10
* the sum would be 10*11/2 = 55
* the same sum could come from 5 5 5 5 5 5 5 5 5 10
* but this is unlikely
*/
for(row = 0; row < *K; row++)
{
total = 0;
for(col = 0; col < *N; col++)
{
total += result[row * (*N) + col];
}
if(total != (*N) * ((*N) + 1) / 2) test = 0;
}
if(test == 0)
{
/* the error function should send an error message through R */
error("Invalid Hypercube\n");
}
#if printResult
for(row = 0; row < *K; row++)
{
for(col = 0; col < *N; col++)
{
Rprintf("%d ", result[row * (*N) + col]);
}
Rprintf("\n");
}
#endif
/* Give the state of the random number generator back to R */
PutRNGstate();
}
/****************************************************************************
[NAME]
SLOW\_ART
[SYNOPSIS]
Image *SLOW_ART(Vector *xvector,
Vector *bvector)
[DESCRIPTION]
This function will iterate towards a solution for the sparse system of
equations \mb{b}=\mb{A x}, where \mb{b} is the sinogram (Radon domain)
and \mb{x} is the reconstructed image to be found. The function uses a
slow version of ART (Algebraric Reconstruction Techniques) where the
transformation matrix is calculated on the fly.
[USAGE]
{\tt Image=ART(TestMatrix, TestSinogram);}
Reconstructs the sinogram {\tt TestSinogram}, returns it as an image.
[REVISION]
Jan. 95, JJJ and PT
July 06, J.Schulz, Modification of ReadRefImage and the condition to
SaveIterions
****************************************************************************/
Image *SLOW_ART(Vector *xvector, Vector *bvector)
{
int ARows,ACols,currentrow,currentiteration,TotalIterations,AntPrint,UseRefImage;
float denom,lambda,brk;
//refxdev=0.0;
float *tempXv,*tempBv;
char DiffFileName[200];
FILE *DiffFile=NULL;
Vector *refxvector=NULL,*AVector;
Image *Recon,*RefImage=NULL;
ARows=bvector->N;
ACols=xvector->N;
Print(_DNormal,"Using ART (slow) to solve %i equations with %i unknowns\n",
ARows,ACols);
UseRefImage=(strlen(itINI.RefFileName)!=0);
if (UseRefImage!=0) {
RefImage=ReadRefImage(itINI.RefFileName);
refxvector=ImageToVector(RefImage);
FreeImage(RefImage);
//refxdev=DeviationVector(refxvector);
strcpy(DiffFileName,itINI.RefFileName);
strcat(DiffFileName,".dif");
DiffFile=fopen(DiffFileName,"wt");
Print(_DNormal,"Logging differences in `%s' \n", DiffFileName);
}
tempXv=xvector->value;
tempBv=bvector->value;
//srand((int)clock());
lambda=itINI.Alpha/itINI.Beta;
TotalIterations=itINI.Iterations*ARows;
AntPrint=(int)(TotalIterations/93);
InitArrays();
for (currentiteration=0;currentiteration<TotalIterations;currentiteration++)
{
if (currentiteration%ARows==0) lambda*=itINI.Beta;
if (currentiteration%AntPrint==0)
Print(_DNormal,"Iterating %6.2f %% done\r",
(currentiteration+1)*100.0/TotalIterations);
if (itINI.IterationType==1)
currentrow=currentiteration%ARows;
else {
//currentrow=(int)(ARows*(float)rand()/(RAND_MAX+1.0));
GetRNGstate();
currentrow = (int)(ARows*runif(0, 1));
//currentrow = (int)(ARows*runif(0, RAND_MAX)/(RAND_MAX+1.0));
PutRNGstate();
}
AVector=GenerateAMatrixRow(currentrow);
denom=MultVectorVector(AVector,AVector);
if (fabs(denom)>1e-9)
{
brk=lambda*(tempBv[currentrow]-MultVectorVector(AVector,xvector))/denom;
ARTUpdateAddVector2(xvector, AVector, brk);
}
FreeVector(AVector);
if ( (itINI.SaveIterations) && (currentiteration != 0) && (!(currentiteration%(ARows*(itINI.SaveIterations)))) )
SaveIteration(xvector,(int)(currentiteration/ARows),itINI.SaveIterationsName);
if (UseRefImage==1)
if (currentiteration%AntPrint==0)
fprintf(DiffFile,"%f %f\n",(double)currentiteration/ARows,
(double)L2NormVector(refxvector,xvector));
/*fprintf(DiffFile,"%f %f\n",(double)currentiteration/ARows,
(double)L2NormVector(refxvector,xvector,refxdev));*/
}
Print(_DNormal," \r");
Recon=VectorToImage(xvector,itINI.XSamples,itINI.YSamples);
if (UseRefImage==1){
Print(_DNormal,"L2 = %9.6f \n",L2NormVector(refxvector,xvector));
//Print(_DNormal,"L2 = %9.6f \n",L2NormVector(refxvector,xvector,refxdev));
FreeVector(refxvector);
fclose(DiffFile);
}
RenameImage(Recon,"ReconstructedImage");
Recon->DeltaX=itINI.DeltaX;
Recon->DeltaY=itINI.DeltaY;
Recon->Xmin=itINI.Xmin;
Recon->Ymin=itINI.Ymin;
return Recon;
}
void kcores_R(double *mat, int *n, int *m, double *corevec, int *dtype, int *pdiag, int *pigeval)
/*Compute k-cores for an input graph. Cores to be computed can be based on
indegree (dtype=0), outdegree (dtype=1), or total degree (dtype=2). Algorithm
used is based on Batagelj and Zaversnik (2002), with some pieces filled in.
It's quite fast -- for large graphs, far more time is spent processing the
input than computing the k-cores! When processing edge values, igeval
determines whether edge values should be ignored (0) or used (1); missing edges
are not counted in either case. When diag=1, diagonals are used; else they are
also omitted.*/
{
int i,j,k,temp,*ord,*nod,diag,igev;
double *stat;
snaNet *g;
slelement *ep;
diag=*pdiag;
igev=*pigeval;
/*Initialize sna internal network*/
GetRNGstate();
g=elMatTosnaNet(mat,n,m);
PutRNGstate();
/*Calculate the sorting stat*/
stat=(double *)R_alloc(*n,sizeof(double));
switch(*dtype){
case 0: /*Indegree*/
for(i=0;i<*n;i++){
stat[i]=0.0;
for(ep=snaFirstEdge(g,i,0);ep!=NULL;ep=ep->next[0])
if(((diag)||(i!=(int)(ep->val)))&&((ep->dp!=NULL)&&(!ISNAN(*(double *)(ep->dp)))))
stat[i]+= igev ? *((double *)(ep->dp)) : 1.0;
}
break;
case 1: /*Outdegree*/
for(i=0;i<*n;i++){
stat[i]=0.0;
for(ep=snaFirstEdge(g,i,1);ep!=NULL;ep=ep->next[0])
if(((diag)||(i!=(int)(ep->val)))&&((ep->dp!=NULL)&&(!ISNAN(*(double *)(ep->dp)))))
stat[i]+= igev ? *((double *)(ep->dp)) : 1.0;
}
break;
case 2: /*Total degree*/
for(i=0;i<*n;i++){
stat[i]=0.0;
for(ep=snaFirstEdge(g,i,0);ep!=NULL;ep=ep->next[0])
if(((diag)||(i!=(int)(ep->val)))&&((ep->dp!=NULL)&&(!ISNAN(*(double *)(ep->dp)))))
stat[i]+= igev ? *((double *)(ep->dp)) : 1.0;
for(ep=snaFirstEdge(g,i,1);ep!=NULL;ep=ep->next[0])
if(((diag)||(i!=(int)(ep->val)))&&((ep->dp!=NULL)&&(!ISNAN(*(double *)(ep->dp)))))
stat[i]+= igev ? *((double *)(ep->dp)) : 1.0;
}
break;
}
/*Set initial core/order values*/
ord=(int *)R_alloc(*n,sizeof(int));
nod=(int *)R_alloc(*n,sizeof(int));
for(i=0;i<*n;i++){
corevec[i]=stat[i];
ord[i]=nod[i]=i;
}
/*Heap reminder: i->(2i+1, 2i+2); parent at floor((i-1)/2); root at 0*/
/*Build a heap, based on the stat vector*/
for(i=1;i<*n;i++){
j=i;
while(j>0){
k=(int)floor((j-1)/2); /*Parent node*/
if(stat[nod[k]]>stat[nod[j]]){ /*Out of order -- swap*/
temp=nod[k];
nod[k]=nod[j];
nod[j]=temp;
ord[nod[j]]=j;
ord[nod[k]]=k;
}
j=k; /*Move to parent*/
}
}
/*Heap test
for(i=0;i<*n;i++){
Rprintf("Pos %d (n=%d, s=%.0f, check=%d): ",i,nod[i],stat[nod[i]],ord[nod[i]]==i);
j=(int)floor((i-1)/2.0);
if(j>=0)
Rprintf("Parent %d (n=%d, s=%.0f), ",j,nod[j],stat[nod[j]]);
else
Rprintf("No Parent (root), ");
j=2*i+1;
if(j<*n)
Rprintf("Lchild %d (n=%d, s=%.0f), ",j,nod[j],stat[nod[j]]);
else
Rprintf("No Lchild, ");
j=2*i+2;
if(j<*n)
Rprintf("Rchild %d (n=%d, s=%.0f)\n",j,nod[j],stat[nod[j]]);
else
Rprintf("No Rchild\n");
}
*/
/*Now, find the k-cores*/
for(i=*n-1;i>=0;i--){
/*Rprintf("Stack currently spans positions 0 to %d.\n",i);*/
corevec[nod[0]]=stat[nod[0]]; /*Coreness of top element is fixed*/
/*Rprintf("Pulled min vertex (%d): coreness was %.0f\n",nod[0],corevec[nod[0]]);*/
/*Swap root w/last element (and re-heap) to remove it*/
temp=nod[0];
nod[0]=nod[i];
nod[i]=temp;
ord[nod[0]]=0;
ord[nod[i]]=i;
j=0;
while(2*j+1<i){
k=2*j+1; /*Get first child*/
if((k<i-1)&&(stat[nod[k+1]]<stat[nod[k]])) /*Use smaller child node*/
k++;
if(stat[nod[k]]<stat[nod[j]]){ /*If child smaller, swap*/
temp=nod[j];
nod[j]=nod[k];
nod[k]=temp;
ord[nod[j]]=j;
ord[nod[k]]=k;
}else
break;
j=k; /*Move to child, repeat*/
}
/*Having removed top element, adjust its neighbors downward*/
switch(*dtype){
case 0: /*Indegree -> update out-neighbors*/
/*Rprintf("Reducing indegree of %d outneighbors...\n",g->outdeg[nod[i]]);*/
for(ep=snaFirstEdge(g,nod[i],1);ep!=NULL;ep=ep->next[0]){
j=(int)ep->val;
if(ord[j]<i){ /*Don't mess with removed nodes!*/
/*Adjust stat*/
/*Rprintf("\t%d: %.0f ->",j,stat[j]);*/
stat[j]=MAX(stat[j]-*((double *)(ep->dp)),corevec[nod[i]]);
/*Rprintf(" %.0f\n",stat[j]);*/
/*Percolate heap upward (stat can only go down!)*/
j=ord[j];
while(floor((j-1)/2)>=0){
k=floor((j-1)/2); /*Parent node*/
if(stat[nod[k]]>stat[nod[j]]){ /*If parent greater, swap*/
temp=nod[j];
nod[j]=nod[k];
nod[k]=temp;
ord[nod[j]]=j;
ord[nod[k]]=k;
}else
break;
j=k; /*Repeat w/new parent*/
}
}
}
break;
case 1: /*Outdegree -> update in-neighbors*/
for(ep=snaFirstEdge(g,nod[i],0);ep!=NULL;ep=ep->next[0]){
j=(int)ep->val;
if(ord[j]<i){ /*Don't mess with removed nodes!*/
/*Adjust stat*/
/*Rprintf("\t%d: %.0f ->",j,stat[j]);*/
stat[j]=MAX(stat[j]-*((double *)(ep->dp)),corevec[nod[i]]);
/*Rprintf(" %.0f\n",stat[j]);*/
/*Percolate heap upward (stat can only go down!)*/
j=ord[j];
while(floor((j-1)/2)>=0){
k=floor((j-1)/2); /*Parent node*/
if(stat[nod[k]]>stat[nod[j]]){ /*If parent greater, swap*/
temp=nod[j];
nod[j]=nod[k];
nod[k]=temp;
ord[nod[j]]=j;
ord[nod[k]]=k;
}else
break;
j=k; /*Repeat w/new parent*/
}
}
}
break;
case 2: /*Total degree -> update all neighbors*/
for(ep=snaFirstEdge(g,nod[i],1);ep!=NULL;ep=ep->next[0]){
j=(int)ep->val;
if(ord[j]<i){ /*Don't mess with removed nodes!*/
/*Adjust stat*/
/*Rprintf("\t%d: %.0f ->",j,stat[j]);*/
stat[j]=MAX(stat[j]-*((double *)(ep->dp)),corevec[nod[i]]);
/*Rprintf(" %.0f\n",stat[j]);*/
/*Percolate heap upward (stat can only go down!)*/
j=ord[j];
while(floor((j-1)/2)>=0){
k=floor((j-1)/2); /*Parent node*/
if(stat[nod[k]]>stat[nod[j]]){ /*If parent greater, swap*/
temp=nod[j];
nod[j]=nod[k];
nod[k]=temp;
ord[nod[j]]=j;
ord[nod[k]]=k;
}else
break;
j=k; /*Repeat w/new parent*/
}
}
}
for(ep=snaFirstEdge(g,nod[i],0);ep!=NULL;ep=ep->next[0]){
j=(int)ep->val;
if(ord[j]<i){ /*Don't mess with removed nodes!*/
/*Adjust stat*/
/*Rprintf("\t%d: %.0f ->",j,stat[j]);*/
stat[j]=MAX(stat[j]-*((double *)(ep->dp)),corevec[nod[i]]);
/*Rprintf(" %.0f\n",stat[j]);*/
/*Percolate heap upward (stat can only go down!)*/
j=ord[j];
while(floor((j-1)/2)>=0){
k=floor((j-1)/2); /*Parent node*/
if(stat[nod[k]]>stat[nod[j]]){ /*If parent greater, swap*/
temp=nod[j];
nod[j]=nod[k];
nod[k]=temp;
ord[nod[j]]=j;
ord[nod[k]]=k;
}else
break;
j=k; /*Repeat w/new parent*/
}
}
}
break;
}
}
}
void cutpointsDir_R(double *mat, int *n, int *m, int *cpstatus)
/*Compute (strong) cutpoints in a directed graph. mat should be the edgelist matrix (of order n), and cpstatus should be a zero-initialized vectors to contain the cutpoint status (0=not a cutpoint, 1=cutpoint). Lacking a good algorithm, I've used something horribly slow and ugly -- nevertheless, it will get the job done for graphs of typical size. Although this should work fine with undirected graphs, it will be hideously slow...use the undirected variant wherever possible.*/
{
snaNet *g;
int i,j,ccount,ccountwoi,tempideg,tempodeg;
slelement *sep,*tempiel,*tempoel,**tempentries;
//Rprintf("Now in cutpointsDir_R. Setting up snaNet\n");
/*Initialize sna internal network*/
GetRNGstate();
g=elMatTosnaNet(mat,n,m);
for(i=0;i<*n;i++){
cpstatus[i]=0;
}
/*Walk the vertices, finding cutpoints by brute force*/
ccount=numStrongComponents(g,n);
//Rprintf("Original number of components: %d\n",ccount);
for(i=0;i<*n;i++)
if((g->indeg[i]>0)&&(g->outdeg[i]>0)){ /*Must be internal to a path*/
//Rprintf("\tEntering with %d\n",i);
/*Temporarily make i an isolate*/
//Rprintf("\tMoving out %d's edges\n",i);
tempideg=g->indeg[i];
tempodeg=g->outdeg[i];
tempiel=g->iel[i];
tempoel=g->oel[i];
g->indeg[i]=0;
g->outdeg[i]=0;
g->iel[i]=NULL;
g->oel[i]=NULL;
tempentries=(slelement **)R_alloc(tempideg,sizeof(slelement *));
//Rprintf("\tMoving out %d edges pointing to %d\n",tempideg,i);
if(tempiel==NULL)
sep=NULL;
else
sep=tempiel->next[0];
for(j=0;sep!=NULL;sep=sep->next[0]){ /*Remove edges pointing to i*/
//Rprintf("\t\t%d, about to do slistDelete\n",j);
tempentries[j++]=slistDelete(g->oel[(int)(sep->val)],(double)i);
//Rprintf("\t\tSending vertex is %d\n",(int)(sep->val));
//Rprintf("\t\t%d, about to do decrement outdegrees\n",j);
/*Decrement outdegree*/
//Rprintf("\t\toutdegree is %d\n", g->outdeg[(int)(sep->val)]);
g->outdeg[(int)(sep->val)]--;
//Rprintf("\t\tnew outdegree is %d\n", g->outdeg[(int)(sep->val)]);
//Rprintf("\t%d -> %d [%.1f]\n",(int)(sep->val), (int)(tempentries[j-1]->val), *((double *)(tempentries[j-1]->dp)));
//Rprintf("\t\tfinished tracer\n");
}
/*Recalculate components (told you this was ugly!)*/
ccountwoi=numStrongComponents(g,n)-1; /*Remove 1 for i*/
//Rprintf("\tNumber of components w/out %d: %d\n",i,ccountwoi);
if(ccountwoi>ccount)
cpstatus[i]++;
/*Restore i to its former glory*/
g->indeg[i]=tempideg;
g->outdeg[i]=tempodeg;
g->iel[i]=tempiel;
g->oel[i]=tempoel;
//Rprintf("\tRestoring edges to %d\n",i);
if(tempiel==NULL)
sep=NULL;
else
sep=tempiel->next[0];
for(j=0;sep!=NULL;sep=sep->next[0]){ /*Restore edges->i*/
g->oel[(int)(sep->val)]=slistInsert(g->oel[(int)(sep->val)],(double)i, tempentries[j++]->dp);
/*Increment outdegree*/
g->outdeg[(int)(sep->val)]++;
//Rprintf("\t\tnew outdegree is %d\n", g->outdeg[(int)(sep->val)]);
//Rprintf("\t%d -> %d [%.1f]\n",(int)(sep->val), (int)(tempentries[j-1]->val), *(double*)(tempentries[j-1]->dp));
}
}
PutRNGstate();
}
SEXP cliques_R(SEXP net, SEXP sn, SEXP sm, SEXP stabulatebyvert, SEXP scomembership, SEXP senumerate)
/*Maximal clique enumeration as an R-callable (.Call) function. net should be an sna edgelist (w/n vertices and m/2 edges), and must be pre-symmetrized. stabulatebyvert should be 0 if no tabulation is to be performed, or 1 for vertex-level tabulation of clique membership. scomembership should be 0 for no co-membership tabulation, 1 for aggregate vertex-by-vertex tabulation, and 2 for size-by-vertex-by-vertex tabulation. Finally, senumerate should be 1 iff the enumerated clique list should be returned. (The current algorithm enumerates them internally, regardless. This is b/c I am lazy, and didn't fold all of the tabulation tasks into the recursion process. Life is hard.)*/
{
int n,tabulate,comemb,enumerate,*gotcomp,*compmemb,i,j,k,maxcsize,pc=0;
double *ccount,*pccountvec,*pcocliquevec=NULL;
snaNet *g;
slelement *sep,*sep2,*k0;
element **clist,*ep;
SEXP smaxcsize,ccountvec,outlist,cliquevec=R_NilValue;
SEXP temp=R_NilValue,sp=R_NilValue,cocliquevec=R_NilValue;
/*Coerce what needs coercin'*/
PROTECT(sn=coerceVector(sn,INTSXP)); pc++;
PROTECT(net=coerceVector(net,REALSXP)); pc++;
PROTECT(stabulatebyvert=coerceVector(stabulatebyvert,INTSXP)); pc++;
PROTECT(scomembership=coerceVector(scomembership,INTSXP)); pc++;
PROTECT(senumerate=coerceVector(senumerate,INTSXP)); pc++;
n=INTEGER(sn)[0];
tabulate=INTEGER(stabulatebyvert)[0];
comemb=INTEGER(scomembership)[0];
enumerate=INTEGER(senumerate)[0];
/*Pre-allocate what needs pre-allocatin'*/
ccount=(double *)R_alloc(n,sizeof(double));
PROTECT(smaxcsize=allocVector(INTSXP,1)); pc++;
clist=(element **)R_alloc(n,sizeof(element *));
for(i=0;i<n;i++){
ccount[i]=0.0;
clist[i]=NULL;
}
/*Initialize sna internal network*/
GetRNGstate();
g=elMatTosnaNet(REAL(net),INTEGER(sn),INTEGER(sm));
/*Calculate the components of g*/
compmemb=undirComponents(g);
/*Accumulate cliques across components*/
gotcomp=(int *)R_alloc(compmemb[0],sizeof(int));
for(i=0;i<compmemb[0];i++)
gotcomp[i]=0;
for(i=0;i<n;i++) /*Move through vertices in order*/
if(!gotcomp[compmemb[i+1]-1]){ /*Take first vertex of each component*/
gotcomp[compmemb[i+1]-1]++; /*Mark component as visited*/
/*Get the first maximal clique in this component*/
k0=slistInsert(NULL,(double)i,NULL);
k0=cliqueFirstChild(g,k0);
/*Recursively enumerate all cliques within the component*/
cliqueRecurse(g,k0,i,clist,ccount,compmemb);
}
PutRNGstate();
/*Find the maximum clique size (to cut down on subsequent memory usage)*/
INTEGER(smaxcsize)[0]=n+1;
for(i=n-1;(i>=0)&(INTEGER(smaxcsize)[0]==n+1);i--)
if(ccount[i]>0.0)
INTEGER(smaxcsize)[0]=i+1;
maxcsize=INTEGER(smaxcsize)[0];
/*Allocate memory for R return value objects*/
if(tabulate){
PROTECT(ccountvec=allocVector(REALSXP,maxcsize*(1+n))); pc++;
for(i=0;i<maxcsize*(1+n);i++)
REAL(ccountvec)[i]=0.0;
}else{
PROTECT(ccountvec=allocVector(REALSXP,maxcsize)); pc++;
for(i=0;i<maxcsize;i++)
REAL(ccountvec)[i]=0.0;
}
pccountvec=REAL(ccountvec);
switch(comemb){
case 0:
cocliquevec=R_NilValue;
pcocliquevec=NULL;
break;
case 1:
PROTECT(cocliquevec=allocVector(REALSXP,n*n)); pc++;
for(i=0;i<n*n;i++)
REAL(cocliquevec)[i]=0.0;
pcocliquevec=REAL(cocliquevec);
break;
case 2:
PROTECT(cocliquevec=allocVector(REALSXP,maxcsize*n*n)); pc++;
for(i=0;i<maxcsize*n*n;i++)
REAL(cocliquevec)[i]=0.0;
pcocliquevec=REAL(cocliquevec);
break;
}
if(enumerate){
PROTECT(cliquevec=allocVector(VECSXP,maxcsize)); pc++;
for(i=0;i<maxcsize;i++){
if(ccount[i]==0.0)
SET_VECTOR_ELT(cliquevec,i,R_NilValue);
else{
PROTECT(temp=allocVector(VECSXP,(int)(ccount[i])));
SET_VECTOR_ELT(cliquevec,i,temp);
UNPROTECT(1);
}
}
}
/*Tabulate, enumerate, and other good things*/
for(i=0;i<maxcsize;i++){
pccountvec[i+tabulate*maxcsize*n]=ccount[i];
if(ccount[i]>0.0){
if(enumerate)
sp=VECTOR_ELT(cliquevec,i);
/*Walk through every clique of size i+1*/
for(j=0,ep=clist[i];ep!=NULL;ep=ep->next){
if(enumerate)
PROTECT(temp=allocVector(INTSXP,i+1));
/*Walk through every clique member*/
for(k=0,sep=((slelement *)(ep->dp))->next[0];sep!=NULL; sep=sep->next[0]){
if(enumerate) /*Add to enumeration list*/
INTEGER(temp)[k++]=(int)(sep->val)+1;
if(tabulate) /*Add to vertex-by-size tabulation*/
pccountvec[i+maxcsize*((int)(sep->val))]++;
switch(comemb){ /*Add co-membership information*/
case 0: /*Case 0 - do nothing*/
break;
case 1: /*Case 1 - just co-membership*/
for(sep2=((slelement *)(ep->dp))->next[0];sep2!=sep; sep2=sep2->next[0]){
pcocliquevec[((int)(sep->val))+n*((int)(sep2->val))]++;
pcocliquevec[((int)(sep2->val))+n*((int)(sep->val))]++;
}
pcocliquevec[((int)(sep->val))+n*((int)(sep->val))]++;
break;
case 2: /*Case 2 - co-membership by size*/
for(sep2=((slelement *)(ep->dp))->next[0];sep2!=sep; sep2=sep2->next[0]){
pcocliquevec[i+maxcsize*((int)(sep->val))+ maxcsize*n*((int)(sep2->val))]++;
pcocliquevec[i+maxcsize*((int)(sep2->val))+ maxcsize*n*((int)(sep->val))]++;
}
pcocliquevec[i+maxcsize*((int)(sep->val))+ maxcsize*n*((int)(sep->val))]++;
break;
}
}
if(enumerate){
SET_VECTOR_ELT(sp,j++,temp);
UNPROTECT(1);
}
}
}
}
/*Prepare and return the results*/
PROTECT(outlist=allocVector(VECSXP,4)); pc++;
SET_VECTOR_ELT(outlist,0,smaxcsize);
SET_VECTOR_ELT(outlist,1,ccountvec);
SET_VECTOR_ELT(outlist,2,cocliquevec);
SET_VECTOR_ELT(outlist,3,cliquevec);
UNPROTECT(pc);
return outlist;
}
// [[Rcpp::register]]
unsigned long enterRNGScope() {
if (RNGScopeCounter == 0) GetRNGstate();
RNGScopeCounter++;
return RNGScopeCounter ;
}
void bsC (
int *nbyclass,
int *classesboth,
int *nrefs,
double *props2,
double *tempties,
double *pis,
double *est,
double *nm,
int *numsamp,
int *offby,
int *K,
int *nc,
int *g,
int *N,
int *n,
int *n0
) {
int i, j;
int isamp, nsamples;
int numberfrom, nextdis, nextresp, tdeg, thisdis;
int activnode, countrefs, mm;
int offbi, Ni, ni, n0i, Ki, gi, ci;
double rU, temp, totaltmp, den, den2;
// nbyclass = the number of members of class k=1,...,K
// size = the size (i.e., degree) of the kth class k=1,...,K
// K = number of classes (of degrees)
// n = RDS sample size
// samplesize = number of w.o.replacement samples to take
// Nk = output: the total number of times a member of class k=1:K is sampled.
GetRNGstate(); /* R function enabling uniform RNG */
nsamples=(*numsamp);
offbi=(*offby);
Ki=(*K);
ci=(*nc);
gi=(*g);
Ni=(*N);
ni=(*n);
n0i=(*n0);
// ni = RDS sample size
// Ki = number of classes (of degrees)
// isamplesize = number of w.o.replacement samples to take
int *newnbyclass = (int *) malloc(sizeof(int) * ci);
double *ntt = (double *) malloc(sizeof(double) * gi*gi);
double *nprop = (double *) malloc(sizeof(double) * gi);
double *nprob = (double *) malloc(sizeof(double) * ci);
double *thistempties = (double *) malloc(sizeof(double) * gi);
int *ideg = (int *) malloc(sizeof(int) * ci);
int *idis = (int *) malloc(sizeof(int) * ci);
int *pclass = (int *) malloc(sizeof(int) * ci);
double *dif = (double *) malloc(sizeof(double) * ci);
double *cdif = (double *) malloc(sizeof(double) * ci);
int *crefs = (int *) malloc(sizeof(int) * ni);
int *csample = (int *) malloc(sizeof(int) * ni);
// for (i=0; i<ci; i++){
// Rprintf("i %d nbyclass[i] %d\n",i,nbyclass[i]);
// }
//
for (j=0; j<(gi*nsamples); j++){
est[j]=0.0;
}
for (j=0; j<nsamples; j++){
nm[j]=0.0;
}
for (i=0; i<ci; i++){
idis[i]=((classesboth[i]-1)/Ki);
ideg[i]=classesboth[i]-Ki*(classesboth[i]/Ki);
if(ideg[i]==0){ideg[i]=Ki;}
}
for (i=0; i<ni; i++){
crefs[i]=0;
}
for (i=0; i<ni; i++){
if(nrefs[i] > 0){crefs[nrefs[i]-1]++;}
}
for (i=1; i<ni; i++){
crefs[i]+=crefs[i-1];
}
// Rprintf("crefs[0] %d crefs[1] %d crefs[2] %d crefs[3] %d\n",crefs[0], crefs[1], crefs[2], crefs[3]);
for (isamp=0; isamp<nsamples; isamp++){
for (j=0; j<ci; j++){
newnbyclass[j] = nbyclass[j];
}
// ntt is a g x g matrix of ties between response classes
for (j=0; j<(gi*gi); j++){
ntt[j]=tempties[j];
}
if(offbi>0){
for (i=0; i<offbi; i++){
dif[0]=props2[0]-newnbyclass[0]/(1.0*Ni);
cdif[0] = dif[0];
if(dif[0]<0.0){dif[0] = 0.0;}
for (j=1; j<ci; j++){
dif[j]=props2[j]-newnbyclass[j]/(1.0*Ni);
if(dif[j]<0.0){dif[j] = 0.0;}
/* compute cumulative probabilities */
cdif[j] = cdif[j-1] + dif[j];
}
rU = unif_rand()*cdif[ci-1];
for (j = 0; j < ci; j++) {if (rU <= cdif[j]) break;}
newnbyclass[j]++;
}
}
if(offbi<0){
for (i=0; i<(-offbi); i++){
dif[0]=newnbyclass[0]/(1.0*Ni) - props2[0];
if(dif[0]<0.0){dif[0] = 0.0;}
if(newnbyclass[0]==1){dif[0] = 0.0;}
totaltmp=dif[0];
cdif[0] = dif[0];
for (j=1; j<ci; j++){
dif[j]=newnbyclass[j]/(1.0*Ni) - props2[j];
if(dif[j]<0.0){dif[j] = 0.0;} if(newnbyclass[j]==1){dif[j] = 0.0;}
totaltmp+=dif[j];
/* compute cumulative probabilities */
cdif[j] = cdif[j-1] + dif[j];
}
if(totaltmp==0.0){
dif[0]=1.0-(props2[0]-newnbyclass[0]/(1.0*Ni));
if(newnbyclass[0]==1){dif[0] = 0.0;}
cdif[0] = dif[0];
for (j=1; j<ci; j++){
dif[j]=1.0-(props2[j]-newnbyclass[j]/(1.0*Ni));
if(newnbyclass[j]==1){dif[j] = 0.0;}
/* compute cumulative probabilities */
cdif[j] = cdif[j-1] + dif[j];
}
}
rU = unif_rand()*cdif[ci-1];
for (j = 0; j < ci; j++) {if (rU <= cdif[j]) break;}
newnbyclass[j]--;
}
}
// Rprintf("make dif\n");
// for (i=0; i<ci; i++){
// Rprintf("i %d nbyclass[i] %d\n",i,nbyclass[i]);
// }
// pclass[i] is the sum of the degrees of those in class i
// So the class is chosen with probability pclass[i]
for (i=0; i<ci; i++){
pclass[i]=ideg[i]*newnbyclass[i];
}
// for (i=0; i<ci; i++){
// if(idis[i]<0 | idis[i]>1){Rprintf("Error: i %d idis[i] %d ideg %d\n",i,idis[i],ideg[i]);}
// }
// for (i=0; i<ci; i++){
// Rprintf("i %d idis[i] %d ideg %d\n",i,idis[i],ideg[i]);
// }
// Sample seeds
for (i=0; i<n0i; i++){
cdif[0] = pclass[0];
for (j=1; j<ci; j++){
/* compute cumulative probabilities */
cdif[j] = cdif[j-1] + pclass[j];
}
rU = unif_rand()*cdif[ci-1];
for (j = 0; j < ci; j++) {if (rU <= cdif[j]) break;}
csample[i] = j;
pclass[j]-=ideg[j];
}
for (i=0; i<gi; i++){
nprop[i]=0.0;
}
for (i=0; i<ci; i++){
// Rprintf("i %d ci %d\n",i,ci);
nprop[idis[i]]=nprop[idis[i]]+newnbyclass[i];
// Rprintf("idis[i] %d nprop[idis[i]] %f nbyclass[i] %d i %d\n",idis[i],nprop[idis[i]],nbyclass[i],i);
// if(idis[i]<0 | idis[i]>1){Rprintf("Error: i %d idis[i] %d ideg %d\n",i,idis[i],ideg[i]);}
}
temp=0.0;
for(i = 0 ; i < gi ; i++){
temp+=nprop[i];
}
for(i = 0 ; i < gi ; i++){
nprop[i]/=temp;
}
for(i = 0 ; i < gi ; i++){
temp=0.0;
for(j = 0 ; j < gi ; j++){
temp+=ntt[i+gi*j];
}
if(temp<=0.0){
for(j = 0 ; j < gi ; j++){
ntt[i+gi*j] = nprop[j];
}
}
temp=0.0;
for(j = 0 ; j < gi ; j++){
temp+=ntt[j+gi*i];
}
if(temp<=0.0){
for(j = 0 ; j < gi ; j++){
ntt[j+gi*i] = nprop[j];
}
}
}
//
// Rprintf("make tempties\n");
rU = unif_rand()*crefs[ni-1];
for (j = 0; j < ni; j++) {if (rU <= crefs[j]) break;}
numberfrom = j+1;
// Rprintf("numberfrom %d\n",numberfrom);
activnode = 0;
countrefs = 0;
for(mm = n0i ; mm < ni ; mm++){ // loop begins!!! mm is not m in the paper!
// if(activnode >= mm){Rprintf("Error: activnode >= mm %d %d\n",activnode,mm);}
// thisdis is the disease status of the active node
thisdis = idis[csample[activnode]];
// nextdis<-.Internal(sample(g, 1, FALSE, tempties[thisdis,]))
for(i = 0 ; i < gi ; i++){
thistempties[i]=ntt[thisdis+gi*i];
}
for (j=1; j<gi; j++){
/* compute cumulative probabilities */
thistempties[j]+=thistempties[j-1];
}
rU = unif_rand()*thistempties[gi-1];
for (j = 0; j < gi; j++) {if (rU <= thistempties[j]) break;}
// nextdis is the disease status of a random referral for a node of
// the same type as the active node
nextdis = j;
// Rprintf("nextdis %d\n",nextdis);
temp=0.0;
for(i = 0 ; i < ci ; i++){
if(idis[i]==nextdis){
nprob[i]=pclass[i];
temp+=pclass[i];
}else{
nprob[i]=0.0;
}
}
if(temp==0.0){
for(i = 0 ; i < ci ; i++){
nprob[i]=pclass[i];
}
// Rprintf("Ran out of %d\n",nextdis);
}
cdif[0] = nprob[0];
for (j=1; j<ci; j++){
/* compute cumulative probabilities */
cdif[j] = cdif[j-1] + nprob[j];
}
rU = unif_rand()*cdif[ci-1];
for (j = 0; j < ci; j++) {if (rU <= cdif[j]) break;}
nextresp = j;
totaltmp=0.0;
for (j=0; j<ci; j++){
totaltmp+=nprob[j];
}
pclass[nextresp]-=ideg[nextresp];
nextdis = idis[nextresp];
tdeg = ideg[nextresp];
for(i = 0 ; i < gi ; i++){
ntt[i+gi*nextdis]*=(totaltmp-tdeg)/totaltmp;
}
// Rprintf("ntt %f %f %f %f\n",ntt[0],ntt[1],ntt[2],ntt[3]);
csample[mm] = nextresp;
countrefs++;
// numberfrom is the number of recruits to get for the current recruiter
if((mm<ni)&(countrefs==numberfrom)){
activnode++; // move to the next seed (or node)!!! i=i+1
countrefs=0;
rU = unif_rand()*crefs[ni-1];
for (j = 0; j < ni; j++) {if (rU <= crefs[j]) break;}
numberfrom = j+1;
}
// Rprintf("make sample %d\n",mm);
// end mm loop
}
// Rprintf("tempties %f %f %f %f\n",ntt[0],ntt[1],ntt[2],ntt[3]);
// if(est[0]==1017){Rprintf("est %f\n",est[0]);}
den=0.0;
den2=0.0;
for (i=0; i<ni; i++){
temp=1.0/pis[csample[i]];
den+=temp;
den2+=(temp*temp);
est[idis[csample[i]]+gi*isamp]+=temp;
// Rprintf("csample %d pix %d pis %f\n",csample[i], csample[i]-UKi*(csample[i]/UKi),pis[csample[i]-UKi*(csample[i]/UKi)]);
// if(csample[i]<0 | csample[i]>(ci-1)){Rprintf("Error: i %d csample[i] %d\n",i, csample[i]);}
}
// Rprintf("est[0] %f est[1] %f\n",est[0],est[1]);
for (j=0; j<gi; j++){
est[j+gi*isamp]/=den;
// Rprintf("est %d %f %f\n",j,den,est[j+gi*isamp]);
}
nm[isamp]=den*den/den2;
}
PutRNGstate(); /* Disable RNG before returning */
free(newnbyclass);
free(ntt);
free(nprop);
free(nprob);
free(thistempties);
free(ideg);
free(idis);
free(pclass);
free(dif);
free(cdif);
free(crefs);
free(csample);
}
// The programme for GIBBS SAMPLING with XB and missing values
// with all summary values (mean, variance/sd, low2.5, up97.5)
// also the predictions into another sites
// output into the txt files
void GIBBS_sumpred_txt_gp(int *aggtype, double *flag, int *its, int *burnin,
int *n, int *T, int *r, int *rT, int *p, int *N, int *report,
int *cov, int *spdecay, double *shape_e, double *shape_eta,
double *phi_a, double *phi_b,
double *prior_a, double *prior_b, double *prior_mubeta,
double *prior_sigbeta, double *prior_omu, double *prior_osig,
double *phi, double *tau, double *phis, int *phik,
double *d, double *sig_e, double *sig_eta,
double *beta, double *X, double *z, double *o, int *constant,
int *nsite, int *valN, double *d12, double *valX, int *transform,
double *accept_f, double *gof, double *penalty)
{
// unsigned iseed = 44;
// srand(iseed);
int its1, col, i, j, r1, rT1, p1, N1, rep1, nsite1, brin, trans1;
its1 = *its;
col = *constant;
// n1 = *n;
r1 = *r;
rT1 = *rT;
p1 = *p;
N1 = *N;
// nr = n1 * r1;
rep1 = *report;
nsite1 = *nsite;
brin = *burnin;
trans1 = *transform;
double *phip, *sig_ep, *sig_etap, *betap;
double *op;
double *phi1, *sig_e1, *sig_eta1, *beta1;
double *o1;
double *oo, *ot, *acc;
double accept1, *mn_rep, *var_rep;
accept1 = 0.0;
mn_rep = (double *) malloc((size_t)((N1)*sizeof(double)));
var_rep = (double *) malloc((size_t)((N1)*sizeof(double)));
for(j=0; j<N1; j++) {
mn_rep[j] = 0.0;
var_rep[j] = 0.0;
}
double *pr_mn, *pr_var;
pr_mn = (double *) malloc((size_t)((nsite1*rT1)*sizeof(double)));
pr_var = (double *) malloc((size_t)((nsite1*rT1)*sizeof(double)));
for(j=0; j<nsite1*rT1; j++) {
pr_mn[j] = 0.0;
pr_var[j] = 0.0;
}
phip = (double *) malloc((size_t)((col)*sizeof(double)));
sig_ep = (double *) malloc((size_t)((col)*sizeof(double)));
sig_etap = (double *) malloc((size_t)((col)*sizeof(double)));
betap = (double *) malloc((size_t)((p1)*sizeof(double)));
op = (double *) malloc((size_t)((N1)*sizeof(double)));
phi1 = (double *) malloc((size_t)((col)*sizeof(double)));
sig_e1 = (double *) malloc((size_t)((col)*sizeof(double)));
sig_eta1 = (double *) malloc((size_t)((col)*sizeof(double)));
beta1 = (double *) malloc((size_t)((p1)*sizeof(double)));
o1 = (double *) malloc((size_t)((N1)*sizeof(double)));
oo = (double *) malloc((size_t)((col)*sizeof(double)));
ot = (double *) malloc((size_t)((col)*sizeof(double)));
acc = (double *) malloc((size_t)((col)*sizeof(double)));
double *zp, *anf;
zp = (double *) malloc((size_t)((nsite1*rT1)*sizeof(double)));
anf = (double *) malloc((size_t)((nsite1*r1)*sizeof(double)));
double *nu, *nup;
nu = (double *) malloc((size_t)((col)*sizeof(double)));
nup = (double *) malloc((size_t)((col)*sizeof(double)));
nu[0] = 0.5;
ext_sige(phi, phi1);
ext_sige(sig_e, sig_e1);
ext_sigeta(sig_eta, sig_eta1);
ext_beta(p, beta, beta1);
ext_o(N, o, o1);
// for missing
for(j=0; j < N1; j++) {
if (flag[j] == 1.0) {
oo[0]=o1[j];
mvrnormal(constant, oo, sig_e1, constant, ot);
z[j] = ot[0];
}
else {
z[j] = z[j];
}
}
FILE *parafile;
parafile = fopen("OutGP_Values_Parameter.txt", "w");
FILE *zpfile;
zpfile = fopen("OutGP_Stats_FittedValue.txt", "w");
FILE *predfile;
predfile = fopen("OutGP_Values_Prediction.txt", "w");
FILE *predfilestat;
predfilestat = fopen("OutGP_Stats_PredValue.txt", "w");
int type1;
type1= *aggtype;
FILE *textan;
// none
if(type1==0) {
textan = fopen("OutGP_NONE.txt", "w");
}
// annual average value
if(type1==1) {
textan = fopen("OutGP_Annual_Average_Prediction.txt", "w");
}
// annual 4th highest value
if(type1==2) {
textan = fopen("OutGP_Annual_4th_Highest_Prediction.txt", "w");
}
// annual w126 option
if(type1==3) {
textan = fopen("OutGP_Annual_w126_Prediction.txt", "w");
}
GetRNGstate();
for(i=0; i < its1; i++) {
JOINT_gp(n, T, r, rT, p, N, cov, spdecay, shape_e, shape_eta, phi_a, phi_b,
prior_a, prior_b, prior_mubeta, prior_sigbeta, prior_omu, prior_osig,
phi1, tau, phis, phik, nu, d, sig_e1, sig_eta1, beta1, X, z, o1, constant,
phip, acc, nup, sig_ep, sig_etap, betap, op);
z_pr_gp(cov, nsite, n, r, rT, T, p, N, valN, d, d12, phip, nup,
sig_ep, sig_etap, betap, X, valX, op, constant, zp);
accept1 += acc[0];
for(j=0; j < p1; j++) {
fprintf(parafile, "%f ", betap[j]);
}
fprintf(parafile, "%f ", sig_ep[0]);
fprintf(parafile, "%f ", sig_etap[0]);
fprintf(parafile, "%f ", phip[0]);
if(cov[0]==4) {
fprintf(parafile, "%f ", nup[0]);
}
fprintf(parafile, "\n");
// for pmcc, fitted
for(j=0; j < N1; j++) {
if(i >= brin) {
oo[0] = op[j];
mvrnormal(constant, oo, sig_e1, constant, ot);
mn_rep[j] += ot[0];
var_rep[j] += ot[0]*ot[0];
}
}
// prediction samples
for(j=0; j<(nsite1*rT1); j++) {
if(trans1 == 0) {
if(i >= brin) {
zp[j] = zp[j];
fprintf(predfile, "%f ", zp[j]);
pr_mn[j] += zp[j];
pr_var[j] += zp[j]*zp[j];
}
}
if(trans1 == 1) {
if(i >= brin) {
zp[j] = zp[j]*zp[j];
fprintf(predfile, "%f ", zp[j]);
pr_mn[j] += zp[j];
pr_var[j] += zp[j]*zp[j];
}
}
if(trans1 == 2) {
if(i >= brin) {
zp[j] = exp(zp[j]);
fprintf(predfile, "%f ", zp[j]);
pr_mn[j] += zp[j];
pr_var[j] += zp[j]*zp[j];
}
}
}
fprintf(predfile, "\n");
if(cov[0]==4) {
GP_para_printRnu(i, its1, rep1, p1, accept1, phip, nup, sig_ep, sig_etap, betap);
}
else {
GP_para_printR (i, its1, rep1, p1, accept1, phip, sig_ep, sig_etap, betap);
}
if(i >= brin) {
annual_aggregate_uneqT(aggtype, nsite, r, T, rT, zp, anf);
// annual_aggregate(aggtype, nsite, r, T, zp, anf);
for(j=0; j<(nsite1*r1); j++) {
fprintf(textan, "%f ", anf[j]);
}
fprintf(textan, "\n");
} // end of loop i >= brin
ext_sige(phip, phi1);
ext_sige(nup, nu);
ext_sige(sig_ep, sig_e1);
ext_sige(sig_etap, sig_eta1);
ext_beta(p, betap, beta1);
// for missing
for(j=0; j < N1; j++) {
if (flag[j] == 1.0) {
oo[0]=op[j];
mvrnormal(constant, oo, sig_e1, constant, ot);
z[j] = ot[0];
}
else {
z[j] = z[j];
}
}
} // end of iteration loop
PutRNGstate();
fclose(parafile);
fclose(predfile);
fclose(textan);
free(phip);
free(nu);
free(nup);
free(sig_ep);
free(sig_etap);
free(betap);
free(op);
free(phi1);
free(sig_e1);
free(sig_eta1);
free(beta1);
free(o1);
free(oo);
free(ot);
free(acc);
free(zp);
free(anf);
accept_f[0] = accept1;
int iit;
iit = 0;
iit = its1 - brin;
double pen, go;
pen = 0.0;
go =0.0;
// fitted zlt, mean and sd
for(j=0; j < N1; j++) {
mn_rep[j] = mn_rep[j]/iit;
var_rep[j] = var_rep[j]/iit;
var_rep[j] = var_rep[j] - mn_rep[j]*mn_rep[j];
fprintf(zpfile, "%f , %f \n", mn_rep[j], sqrt(var_rep[j]));
}
fclose(zpfile);
// pmcc
for(j=0; j < N1; j++) {
if (flag[j] == 1.0) {
mn_rep[j] = 0.0;
var_rep[j] = 0.0;
}
else {
mn_rep[j] = mn_rep[j];
var_rep[j] = var_rep[j];
mn_rep[j] = (mn_rep[j] - z[j])*(mn_rep[j] - z[j]);
}
pen += var_rep[j];
go += mn_rep[j];
}
free(mn_rep);
free(var_rep);
penalty[0] = pen;
gof[0] = go;
// predicted mean and sd
for(j=0; j < nsite1*rT1; j++) {
pr_mn[j] = pr_mn[j]/iit;
pr_var[j] = pr_var[j]/iit;
pr_var[j] = pr_var[j] - pr_mn[j]*pr_mn[j];
fprintf(predfilestat, "%f , %f \n", pr_mn[j], sqrt(pr_var[j]));
}
fclose(predfilestat);
free(pr_mn);
free(pr_var);
// Rprintf("\n---------------------------------------------------------\n");
return;
}
/* THE FUNCTION TO SIMULATE THE POLYTOMOUS MODEL VALUES */
SEXP simPoly( SEXP prob, SEXP K ) /* a probability matrix and number of categories */
{
/* 1) create scalars in C to hold temporary number */
int n_ppl, n_it, n_cat; /* for the item, person, and category dimensions */
double p; /* for the probability of correct */
double u; /* for the simulated uniform, random number */
int i, j, k; /* for the loop iteration */
/* 2)
* a) digest the datastructures from R into C */
int *dimProb;
double *pprob, *pK; /* pointers to prob matrix and K */
/* b) get the dimensions of prob */
dimProb = getDims( prob );
/* c) protect the R objects */
PROTECT( prob = coerceVector( prob, REALSXP ) );
PROTECT( K = coerceVector( K, REALSXP ) );
/* d) point to the R objects */
pprob = REAL( prob ); pK = REAL( K );
/* e) get the dimensions of everything else */
n_ppl = dimProb[ 0 ] / pK[ 0 ] ;
n_it = dimProb[ 1 ];
n_cat = pK[ 0 ];
/* 3)
* a) create sim to hold the answer */
SEXP sim;
double *psim; /* a pointer to sim */
/* b) make sure to allocate space for the matrix */
PROTECT( sim = allocMatrix( REALSXP, n_ppl, n_it ) );
psim = REAL( sim );
/* c) get the RNG (random number) state from R */
GetRNGstate();
/* d) simulate the response for each person */
for( i = 0; i < n_ppl; i++ ){
for( j = 0; j < n_it; j++ ){
u = unif_rand(); /* random number */
p = 0; /* temp probability */
psim[ j * n_ppl + i ] = 1; /* initialize to 1 */
for( k = 0; k < n_cat; k++ ){
p += pprob[ j * n_ppl * n_cat + i * n_cat + k ];
if( p <= u )
psim[ j * n_ppl + i ] = k + 2;
}
}
}
/* put the RNG (random number) state back to R */
PutRNGstate();
/* wrap up and return the result to R */
UNPROTECT( 3 );
return( sim );
}
SEXP glm_mcmcbas(SEXP Y, SEXP X, SEXP Roffset, SEXP Rweights,
SEXP Rprobinit, SEXP Rmodeldim,
SEXP modelprior, SEXP betaprior, SEXP Rbestmodel,SEXP plocal,
SEXP BURNIN_Iterations,
SEXP family, SEXP Rcontrol,
SEXP Rupdate, SEXP Rlaplace)
{
int nProtected = 0;
int nModels=LENGTH(Rmodeldim);
SEXP ANS = PROTECT(allocVector(VECSXP, 17)); ++nProtected;
SEXP ANS_names = PROTECT(allocVector(STRSXP, 17)); ++nProtected;
SEXP Rprobs = PROTECT(duplicate(Rprobinit)); ++nProtected;
SEXP MCMCprobs= PROTECT(duplicate(Rprobinit)); ++nProtected;
SEXP R2 = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP shrinkage = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP modelspace = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP modeldim = PROTECT(duplicate(Rmodeldim)); ++nProtected;
SEXP counts = PROTECT(duplicate(Rmodeldim)); ++nProtected;
SEXP beta = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP se = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP deviance = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP modelprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP priorprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP logmarg = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP sampleprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP Q = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP Rintercept = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP NumUnique = PROTECT(allocVector(INTSXP, 1)); ++nProtected;
double *probs, MH=0.0, prior_m=1.0,shrinkage_m, logmargy, postold, postnew;
int i, m, n, pmodel_old, *bestmodel;
int mcurrent, n_sure;
glmstptr *glmfamily;
glmfamily = make_glmfamily_structure(family);
betapriorptr *betapriorfamily;
betapriorfamily = make_betaprior_structure(betaprior, family);
//get dimsensions of all variables
int p = INTEGER(getAttrib(X,R_DimSymbol))[1];
int k = LENGTH(modelprobs);
int update = INTEGER(Rupdate)[0];
double eps = DBL_EPSILON;
struct Var *vars = (struct Var *) R_alloc(p, sizeof(struct Var)); // Info about the model variables.
probs = REAL(Rprobs);
n = sortvars(vars, probs, p);
for (i =n; i <p; i++) REAL(MCMCprobs)[vars[i].index] = probs[vars[i].index];
for (i =0; i <n; i++) REAL(MCMCprobs)[vars[i].index] = 0.0;
// fill in the sure things
int *model = ivecalloc(p);
for (i = n, n_sure = 0; i < p; i++) {
model[vars[i].index] = (int) vars[i].prob;
if (model[vars[i].index] == 1) ++n_sure;
}
GetRNGstate();
NODEPTR tree, branch;
tree = make_node(-1.0);
// Rprintf("For m=0, Initialize Tree with initial Model\n");
m = 0;
bestmodel = INTEGER(Rbestmodel);
INTEGER(modeldim)[m] = n_sure;
// Rprintf("Create Tree\n");
branch = tree;
CreateTree(branch, vars, bestmodel, model, n, m, modeldim);
int pmodel = INTEGER(modeldim)[m];
SEXP Rmodel_m = PROTECT(allocVector(INTSXP,pmodel));
GetModel_m(Rmodel_m, model, p);
//evaluate logmargy and shrinkage
SEXP glm_fit = PROTECT(glm_FitModel(X, Y, Rmodel_m, Roffset, Rweights,
glmfamily, Rcontrol, Rlaplace,
betapriorfamily));
prior_m = compute_prior_probs(model,pmodel,p, modelprior);
logmargy = REAL(getListElement(getListElement(glm_fit, "lpy"),"lpY"))[0];
shrinkage_m = REAL(getListElement(getListElement(glm_fit, "lpy"),
"shrinkage"))[0];
SetModel2(logmargy, shrinkage_m, prior_m, sampleprobs, logmarg, shrinkage, priorprobs, m);
SetModel1(glm_fit, Rmodel_m, beta, se, modelspace, deviance, R2,
Q, Rintercept, m);
UNPROTECT(2);
int nUnique=0, newmodel=0;
double *real_model = vecalloc(n);
int *modelold = ivecalloc(p);
int old_loc = 0;
int new_loc;
pmodel_old = pmodel;
nUnique=1;
INTEGER(counts)[0] = 0;
postold = REAL(logmarg)[m] + log(REAL(priorprobs)[m]);
memcpy(modelold, model, sizeof(int)*p);
m = 0;
int *varin= ivecalloc(p);
int *varout= ivecalloc(p);
double problocal = REAL(plocal)[0];
while (nUnique < k && m < INTEGER(BURNIN_Iterations)[0]) {
memcpy(model, modelold, sizeof(int)*p);
pmodel = n_sure;
MH = GetNextModelCandidate(pmodel_old, n, n_sure, model, vars, problocal, varin, varout);
branch = tree;
newmodel= 0;
for (i = 0; i< n; i++) {
int bit = model[vars[i].index];
if (bit == 1) {
if (branch->one != NULL) branch = branch->one;
else newmodel = 1;
} else {
if (branch->zero != NULL) branch = branch->zero;
else newmodel = 1;
}
pmodel += bit;
}
if (pmodel == n_sure || pmodel == n + n_sure) {
MH = 1.0/(1.0 - problocal);
}
if (newmodel == 1) {
new_loc = nUnique;
PROTECT(Rmodel_m = allocVector(INTSXP,pmodel));
GetModel_m(Rmodel_m, model, p);
glm_fit = PROTECT(glm_FitModel(X, Y, Rmodel_m, Roffset, Rweights,
glmfamily, Rcontrol, Rlaplace,
betapriorfamily));
prior_m = compute_prior_probs(model,pmodel,p, modelprior);
logmargy = REAL(getListElement(getListElement(glm_fit, "lpy"),"lpY"))[0];
shrinkage_m = REAL(getListElement(getListElement(glm_fit, "lpy"),
"shrinkage"))[0];
postnew = logmargy + log(prior_m);
}
else {
new_loc = branch->where;
postnew = REAL(logmarg)[new_loc] + log(REAL(priorprobs)[new_loc]);
}
MH *= exp(postnew - postold);
// Rprintf("MH new %lf old %lf\n", postnew, postold);
if (unif_rand() < MH) {
if (newmodel == 1) {
new_loc = nUnique;
insert_model_tree(tree, vars, n, model, nUnique);
INTEGER(modeldim)[nUnique] = pmodel;
//Rprintf("model %d: %d variables\n", m, pmodel);
SetModel2(logmargy, shrinkage_m, prior_m, sampleprobs, logmarg, shrinkage, priorprobs, nUnique);
SetModel1(glm_fit, Rmodel_m, beta, se, modelspace, deviance, R2, Q, Rintercept, nUnique);
UNPROTECT(2);
++nUnique;
}
old_loc = new_loc;
postold = postnew;
pmodel_old = pmodel;
memcpy(modelold, model, sizeof(int)*p);
} else {
if (newmodel == 1) UNPROTECT(2);
}
INTEGER(counts)[old_loc] += 1;
for (i = 0; i < n; i++) {
// store in opposite order so nth variable is first
real_model[n-1-i] = (double) modelold[vars[i].index];
REAL(MCMCprobs)[vars[i].index] += (double) modelold[vars[i].index];
}
m++;
}
for (i = 0; i < n; i++) {
REAL(MCMCprobs)[vars[i].index] /= (double) m;
}
// Compute marginal probabilities
mcurrent = nUnique;
// Rprintf("NumUnique Models Accepted %d \n", nUnique);
compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent);
compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p);
// Now sample W/O Replacement
INTEGER(NumUnique)[0] = nUnique;
if (nUnique < k) {
int *modelwork= ivecalloc(p);
double *pigamma = vecalloc(p);
update_probs(probs, vars, mcurrent, k, p);
update_tree(modelspace, tree, modeldim, vars, k,p,n,mcurrent, modelwork);
for (m = nUnique; m < k; m++) {
for (i = n; i < p; i++) {
INTEGER(modeldim)[m] += model[vars[i].index];
}
branch = tree;
GetNextModel_swop(branch, vars, model, n, m, pigamma, problocal, modeldim, bestmodel);
/* Now subtract off the visited probability mass. */
branch=tree;
Substract_visited_probability_mass(branch, vars, model, n, m, pigamma,eps);
/* Now get model specific calculations */
pmodel = INTEGER(modeldim)[m];
PROTECT(Rmodel_m = allocVector(INTSXP,pmodel));
GetModel_m(Rmodel_m, model, p);
glm_fit = PROTECT(glm_FitModel(X, Y, Rmodel_m, Roffset, Rweights,
glmfamily, Rcontrol, Rlaplace,
betapriorfamily));
prior_m = compute_prior_probs(model,pmodel,p, modelprior);
logmargy = REAL(getListElement(getListElement(glm_fit, "lpy"),"lpY"))[0];
shrinkage_m = REAL(getListElement(getListElement(glm_fit, "lpy"),
"shrinkage"))[0];
SetModel2(logmargy, shrinkage_m, prior_m, sampleprobs, logmarg, shrinkage, priorprobs, m);
SetModel1(glm_fit, Rmodel_m, beta, se, modelspace, deviance, R2, Q, Rintercept, m);
UNPROTECT(2);
REAL(sampleprobs)[m] = pigamma[0];
//update marginal inclusion probs
if (m > 1) {
double mod;
double rem = modf((double) m/(double) update, &mod);
if (rem == 0.0) {
int mcurrent = m;
compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent);
compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p);
if (update_probs(probs, vars, mcurrent, k, p) == 1) {
// Rprintf("Updating Model Tree %d \n", m);
update_tree(modelspace, tree, modeldim, vars, k,p,n,mcurrent, modelwork);
}
}
}
}
}
compute_modelprobs(modelprobs, logmarg, priorprobs,k);
compute_margprobs(modelspace, modeldim, modelprobs, probs, k, p);
INTEGER(NumUnique)[0] = nUnique;
SET_VECTOR_ELT(ANS, 0, Rprobs);
SET_STRING_ELT(ANS_names, 0, mkChar("probne0"));
SET_VECTOR_ELT(ANS, 1, modelspace);
SET_STRING_ELT(ANS_names, 1, mkChar("which"));
SET_VECTOR_ELT(ANS, 2, logmarg);
SET_STRING_ELT(ANS_names, 2, mkChar("logmarg"));
SET_VECTOR_ELT(ANS, 3, modelprobs);
SET_STRING_ELT(ANS_names, 3, mkChar("postprobs"));
SET_VECTOR_ELT(ANS, 4, priorprobs);
SET_STRING_ELT(ANS_names, 4, mkChar("priorprobs"));
SET_VECTOR_ELT(ANS, 5, sampleprobs);
SET_STRING_ELT(ANS_names, 5, mkChar("sampleprobs"));
SET_VECTOR_ELT(ANS, 6, deviance);
SET_STRING_ELT(ANS_names, 6, mkChar("deviance"));
SET_VECTOR_ELT(ANS, 7, beta);
SET_STRING_ELT(ANS_names, 7, mkChar("mle"));
SET_VECTOR_ELT(ANS, 8, se);
SET_STRING_ELT(ANS_names, 8, mkChar("mle.se"));
SET_VECTOR_ELT(ANS, 9, shrinkage);
SET_STRING_ELT(ANS_names, 9, mkChar("shrinkage"));
SET_VECTOR_ELT(ANS, 10, modeldim);
SET_STRING_ELT(ANS_names, 10, mkChar("size"));
SET_VECTOR_ELT(ANS, 11, R2);
SET_STRING_ELT(ANS_names, 11, mkChar("R2"));
SET_VECTOR_ELT(ANS, 12, counts);
SET_STRING_ELT(ANS_names, 12, mkChar("freq"));
SET_VECTOR_ELT(ANS, 13, MCMCprobs);
SET_STRING_ELT(ANS_names, 13, mkChar("probs.MCMC"));
SET_VECTOR_ELT(ANS, 14, NumUnique);
SET_STRING_ELT(ANS_names, 14, mkChar("n.Unique"));
SET_VECTOR_ELT(ANS, 15, Q);
SET_STRING_ELT(ANS_names, 15, mkChar("Q"));
SET_VECTOR_ELT(ANS, 16, Rintercept);
SET_STRING_ELT(ANS_names, 16, mkChar("intercept"));
setAttrib(ANS, R_NamesSymbol, ANS_names);
PutRNGstate();
UNPROTECT(nProtected);
return(ANS);
}
void F77_SUB(rndstart)(void) { GetRNGstate(); }
//extern "C"
SEXP mc_irf_var(SEXP varobj, SEXP nsteps, SEXP draws)
{
int m, p, dr=INTEGER(draws)[0], ns=INTEGER(nsteps)[0], T, df, i;
SEXP AR, Y, Bhat, XR, prior, hstar, meanS, output;
// Get # vars/lags/steps/draws/T/df
PROTECT(AR = listElt(varobj, "ar.coefs"));
PROTECT(Y = listElt(varobj, "Y"));
m = INTEGER(getAttrib(AR, R_DimSymbol))[0]; //#vars
p = INTEGER(getAttrib(AR, R_DimSymbol))[2]; //#lags
T = nrows(Y); df = T - m*p - m - 1;
UNPROTECT(2);
// Put coefficients from varobj$Bhat in Bcoefs vector (m^2*p, 1)
PROTECT(Bhat = coerceVector(listElt(varobj, "Bhat"), REALSXP));
Matrix bcoefs = R2Cmat(Bhat, m*p, m);
bcoefs = bcoefs.AsColumn();
UNPROTECT(1);
// Define X(T x m*p) subset of varobj$X and XXinv as solve(X'X)
PROTECT(XR = coerceVector(listElt(varobj,"X"),REALSXP));
Matrix X = R2Cmat(XR, T, m*p), XXinv;
UNPROTECT(1);
// Get the correct moment matrix
PROTECT(prior = listElt(varobj,"prior"));
if(!isNull(prior)){
PROTECT(hstar = coerceVector(listElt(varobj,"hstar"),REALSXP));
XXinv = R2Cmat(hstar, m*p, m*p).i();
UNPROTECT(1);
}
else { XXinv = (X.t()*X).i(); }
UNPROTECT(1);
// Get the transpose of the Cholesky decomp of XXinv
SymmetricMatrix XXinvSym; XXinvSym << XXinv;
XXinv = Cholesky(XXinvSym);
// Cholesky of covariance
PROTECT(meanS = coerceVector(listElt(varobj,"mean.S"),REALSXP));
SymmetricMatrix meanSSym; meanSSym << R2Cmat(meanS, m, m);
Matrix Sigmat = Cholesky(meanSSym);
UNPROTECT(1);
// Matricies needed for the loop
ColumnVector bvec; bvec=0.0;
Matrix sqrtwish, impulse(dr,m*m*ns); impulse = 0.0;
SymmetricMatrix sigmadraw; sigmadraw = 0.0;
IdentityMatrix I(m);
GetRNGstate();
// Main Loop
for (i=1; i<=dr; i++){
// Wishart/Beta draws
sigmadraw << Sigmat*(T*rwish(I,df).i())*Sigmat.t();
sqrtwish = Cholesky(sigmadraw);
bvec = bcoefs+KP(sqrtwish, XXinv)*rnorms(m*m*p);
// IRF computation
impulse.Row(i) = irf_var_from_beta(sqrtwish, bvec, ns).t();
if (!(i%1000)){ Rprintf("Monte Carlo IRF Iteration = %d\n",i); }
} // end main loop
PutRNGstate();
int dims[]={dr,ns,m*m};
PROTECT(output = C2R3D(impulse,dims));
setclass(output,"mc.irf.VAR");
UNPROTECT(1);
return output;
}
SEXP Random2(SEXP args)
{
if (!isVectorList(CAR(args))) error("incorrect usage");
SEXP x, a, b;
R_xlen_t i, n, na, nb;
ran2 fn = NULL; /* -Wall */
const char *dn = CHAR(STRING_ELT(getListElement(CAR(args), "name"), 0));
SEXPTYPE type = REALSXP;
if (streql(dn, "rbeta")) fn = &rbeta;
else if (streql(dn, "rbinom")) {
type = INTSXP;
fn = &rbinom;
} else if (streql(dn, "rcauchy")) fn = &rcauchy;
else if (streql(dn, "rf")) fn = &rf;
else if (streql(dn, "rgamma")) fn = &rgamma;
else if (streql(dn, "rlnorm")) fn = &rlnorm;
else if (streql(dn, "rlogis")) fn = &rlogis;
else if (streql(dn, "rnbinom")) {
type = INTSXP;
fn = &rnbinom;
} else if (streql(dn, "rnorm")) fn = &rnorm;
else if (streql(dn, "runif")) fn = &runif;
else if (streql(dn, "rweibull")) fn = &rweibull;
else if (streql(dn, "rwilcox")) {
type = INTSXP;
fn = &rwilcox;
} else if (streql(dn, "rnchisq")) fn = &rnchisq;
else if (streql(dn, "rnbinom_mu")) {
fn = &rnbinom_mu;
} else error(_("invalid arguments"));
args = CDR(args);
if (!isVector(CAR(args)) ||
!isNumeric(CADR(args)) ||
!isNumeric(CADDR(args)))
error(_("invalid arguments"));
if (XLENGTH(CAR(args)) == 1) {
#ifdef LONG_VECTOR_SUPPORT
double dn = asReal(CAR(args));
if (ISNAN(dn) || dn < 0 || dn > R_XLEN_T_MAX)
error(_("invalid arguments"));
n = (R_xlen_t) dn;
#else
n = asInteger(CAR(args));
if (n == NA_INTEGER || n < 0)
error(_("invalid arguments"));
#endif
}
else n = XLENGTH(CAR(args));
PROTECT(x = allocVector(type, n));
if (n == 0) {
UNPROTECT(1);
return(x);
}
na = XLENGTH(CADR(args));
nb = XLENGTH(CADDR(args));
if (na < 1 || nb < 1) {
if (type == INTSXP)
for (i = 0; i < n; i++) INTEGER(x)[i] = NA_INTEGER;
else
for (i = 0; i < n; i++) REAL(x)[i] = NA_REAL;
for (i = 0; i < n; i++) REAL(x)[i] = NA_REAL;
warning(_("NAs produced"));
}
else {
Rboolean naflag = FALSE;
PROTECT(a = coerceVector(CADR(args), REALSXP));
PROTECT(b = coerceVector(CADDR(args), REALSXP));
GetRNGstate();
double *ra = REAL(a), *rb = REAL(b);
if (type == INTSXP) {
int *ix = INTEGER(x); double rx;
errno = 0;
for (R_xlen_t i = 0; i < n; i++) {
// if ((i+1) % NINTERRUPT) R_CheckUserInterrupt();
rx = fn(ra[i % na], rb[i % nb]);
if (ISNAN(rx) || rx > INT_MAX || rx <= INT_MIN) {
naflag = TRUE;
ix[i] = NA_INTEGER;
} else ix[i] = (int) rx;
}
} else {
double *rx = REAL(x);
errno = 0;
for (R_xlen_t i = 0; i < n; i++) {
// if ((i+1) % NINTERRUPT) R_CheckUserInterrupt();
rx[i] = fn(ra[i % na], rb[i % nb]);
if (ISNAN(rx[i])) naflag = TRUE;
}
}
if (naflag) warning(_("NAs produced"));
PutRNGstate();
UNPROTECT(2);
}
UNPROTECT(1);
return x;
}
SEXP gbm
(
SEXP radY, // outcome or response
SEXP radOffset, // offset for f(x), NA for no offset
SEXP radX,
SEXP raiXOrder,
SEXP radWeight,
SEXP radMisc, // other row specific data (eg failure time), NA=no Misc
SEXP rcRows,
SEXP rcCols,
SEXP racVarClasses,
SEXP ralMonotoneVar,
SEXP rszFamily,
SEXP rcTrees,
SEXP rcDepth, // interaction depth
SEXP rcMinObsInNode,
SEXP rdShrinkage,
SEXP rdBagFraction,
SEXP rcTrain,
SEXP radFOld,
SEXP rcCatSplitsOld,
SEXP rcTreesOld,
SEXP rfVerbose
)
{
unsigned long hr = 0;
SEXP rAns = NULL;
SEXP rNewTree = NULL;
SEXP riSplitVar = NULL;
SEXP rdSplitPoint = NULL;
SEXP riLeftNode = NULL;
SEXP riRightNode = NULL;
SEXP riMissingNode = NULL;
SEXP rdErrorReduction = NULL;
SEXP rdWeight = NULL;
SEXP rdPred = NULL;
SEXP rdInitF = NULL;
SEXP radF = NULL;
SEXP radTrainError = NULL;
SEXP radValidError = NULL;
SEXP radOOBagImprove = NULL;
SEXP rSetOfTrees = NULL;
SEXP rSetSplitCodes = NULL;
SEXP rSplitCode = NULL;
VEC_VEC_CATEGORIES vecSplitCodes;
int i = 0;
int iT = 0;
int cTrees = INTEGER(rcTrees)[0];
const int cResultComponents = 7;
// rdInitF, radF, radTrainError, radValidError, radOOBagImprove
// rSetOfTrees, rSetSplitCodes
const int cTreeComponents = 8;
// riSplitVar, rdSplitPoint, riLeftNode,
// riRightNode, riMissingNode, rdErrorReduction, rdWeight, rdPred
int cNodes = 0;
int cTrain = INTEGER(rcTrain)[0];
double dTrainError = 0.0;
double dValidError = 0.0;
double dOOBagImprove = 0.0;
CGBM *pGBM = NULL;
CDataset *pData = NULL;
CDistribution *pDist = NULL;
// set up the dataset
pData = new CDataset();
if(pData==NULL)
{
hr = GBM_OUTOFMEMORY;
goto Error;
}
// initialize R's random number generator
GetRNGstate();
// initialize some things
hr = gbm_setup(REAL(radY),
REAL(radOffset),
REAL(radX),
INTEGER(raiXOrder),
REAL(radWeight),
REAL(radMisc),
INTEGER(rcRows)[0],
INTEGER(rcCols)[0],
INTEGER(racVarClasses),
INTEGER(ralMonotoneVar),
CHAR(STRING_ELT(rszFamily,0)),
INTEGER(rcTrees)[0],
INTEGER(rcDepth)[0],
INTEGER(rcMinObsInNode)[0],
REAL(rdShrinkage)[0],
REAL(rdBagFraction)[0],
INTEGER(rcTrain)[0],
pData,
pDist);
if(GBM_FAILED(hr))
{
goto Error;
}
// allocate the GBM
pGBM = new CGBM();
if(pGBM==NULL)
{
hr = GBM_OUTOFMEMORY;
goto Error;
}
// initialize the GBM
hr = pGBM->Initialize(pData,
pDist,
REAL(rdShrinkage)[0],
cTrain,
REAL(rdBagFraction)[0],
INTEGER(rcDepth)[0],
INTEGER(rcMinObsInNode)[0]);
if(GBM_FAILED(hr))
{
goto Error;
}
// allocate the main return object
PROTECT(rAns = allocVector(VECSXP, cResultComponents));
// allocate the initial value
PROTECT(rdInitF = allocVector(REALSXP, 1));
SET_VECTOR_ELT(rAns,0,rdInitF);
UNPROTECT(1); // rdInitF
// allocate the predictions
PROTECT(radF = allocVector(REALSXP, pData->cRows));
SET_VECTOR_ELT(rAns,1,radF);
UNPROTECT(1); // radF
if(ISNA(REAL(radFOld)[0])) // check for old predictions
{
// set the initial value of F as a constant
hr = pDist->InitF(pData->adY,
pData->adMisc,
pData->adOffset,
pData->adWeight,
REAL(rdInitF)[0],
cTrain);
for(i=0; i < pData->cRows; i++)
{
REAL(radF)[i] = REAL(rdInitF)[0];
}
}
else
{
for(i=0; i < pData->cRows; i++)
{
REAL(radF)[i] = REAL(radFOld)[i];
}
}
// allocate space for the performance measures
PROTECT(radTrainError = allocVector(REALSXP, cTrees));
PROTECT(radValidError = allocVector(REALSXP, cTrees));
PROTECT(radOOBagImprove = allocVector(REALSXP, cTrees));
SET_VECTOR_ELT(rAns,2,radTrainError);
SET_VECTOR_ELT(rAns,3,radValidError);
SET_VECTOR_ELT(rAns,4,radOOBagImprove);
UNPROTECT(3); // radTrainError , radValidError, radOOBagImprove
// allocate the component for the tree structures
PROTECT(rSetOfTrees = allocVector(VECSXP, cTrees));
SET_VECTOR_ELT(rAns,5,rSetOfTrees);
UNPROTECT(1); // rSetOfTrees
if(INTEGER(rfVerbose)[0])
{
Rprintf("Iter TrainDeviance ValidDeviance StepSize Improve\n");
}
for(iT=0; iT<cTrees; iT++)
{
hr = pGBM->iterate(REAL(radF),
dTrainError,dValidError,dOOBagImprove,
cNodes);
if(GBM_FAILED(hr))
{
goto Error;
}
// store the performance measures
REAL(radTrainError)[iT] = dTrainError;
REAL(radValidError)[iT] = dValidError;
REAL(radOOBagImprove)[iT] = dOOBagImprove;
// allocate the new tree component for the R list structure
PROTECT(rNewTree = allocVector(VECSXP, cTreeComponents));
// riNodeID,riSplitVar,rdSplitPoint,riLeftNode,
// riRightNode,riMissingNode,rdErrorReduction,rdWeight
PROTECT(riSplitVar = allocVector(INTSXP, cNodes));
PROTECT(rdSplitPoint = allocVector(REALSXP, cNodes));
PROTECT(riLeftNode = allocVector(INTSXP, cNodes));
PROTECT(riRightNode = allocVector(INTSXP, cNodes));
PROTECT(riMissingNode = allocVector(INTSXP, cNodes));
PROTECT(rdErrorReduction = allocVector(REALSXP, cNodes));
PROTECT(rdWeight = allocVector(REALSXP, cNodes));
PROTECT(rdPred = allocVector(REALSXP, cNodes));
SET_VECTOR_ELT(rNewTree,0,riSplitVar);
SET_VECTOR_ELT(rNewTree,1,rdSplitPoint);
SET_VECTOR_ELT(rNewTree,2,riLeftNode);
SET_VECTOR_ELT(rNewTree,3,riRightNode);
SET_VECTOR_ELT(rNewTree,4,riMissingNode);
SET_VECTOR_ELT(rNewTree,5,rdErrorReduction);
SET_VECTOR_ELT(rNewTree,6,rdWeight);
SET_VECTOR_ELT(rNewTree,7,rdPred);
UNPROTECT(cTreeComponents);
SET_VECTOR_ELT(rSetOfTrees,iT,rNewTree);
UNPROTECT(1); // rNewTree
hr = gbm_transfer_to_R(pGBM,
vecSplitCodes,
INTEGER(riSplitVar),
REAL(rdSplitPoint),
INTEGER(riLeftNode),
INTEGER(riRightNode),
INTEGER(riMissingNode),
REAL(rdErrorReduction),
REAL(rdWeight),
REAL(rdPred),
INTEGER(rcCatSplitsOld)[0]);
if((iT <= 9) ||
((iT+1+INTEGER(rcTreesOld)[0])/100 ==
(iT+1+INTEGER(rcTreesOld)[0])/100.0) ||
(iT==cTrees-1))
{
R_CheckUserInterrupt();
if(INTEGER(rfVerbose)[0])
{
Rprintf("%6d %13.4f %15.4f %10.4f %9.4f\n",
iT+1+INTEGER(rcTreesOld)[0],
REAL(radTrainError)[iT],
REAL(radValidError)[iT],
REAL(rdShrinkage)[0],
REAL(radOOBagImprove)[iT]);
}
}
}
if(INTEGER(rfVerbose)[0]) Rprintf("\n");
// transfer categorical splits to R
PROTECT(rSetSplitCodes = allocVector(VECSXP, vecSplitCodes.size()));
SET_VECTOR_ELT(rAns,6,rSetSplitCodes);
UNPROTECT(1); // rSetSplitCodes
for(i=0; i<(int)vecSplitCodes.size(); i++)
{
PROTECT(rSplitCode =
allocVector(INTSXP, size_of_vector(vecSplitCodes,i)));
SET_VECTOR_ELT(rSetSplitCodes,i,rSplitCode);
UNPROTECT(1); // rSplitCode
hr = gbm_transfer_catsplits_to_R(i,
vecSplitCodes,
INTEGER(rSplitCode));
}
// dump random number generator seed
#ifdef NOISY_DEBUG
Rprintf("PutRNGstate\n");
#endif
PutRNGstate();
Cleanup:
UNPROTECT(1); // rAns
#ifdef NOISY_DEBUG
Rprintf("destructing\n");
#endif
if(pGBM != NULL)
{
delete pGBM;
pGBM = NULL;
}
if(pDist != NULL)
{
delete pDist;
pDist = NULL;
}
if(pData != NULL)
{
delete pData;
pData = NULL;
}
return rAns;
Error:
goto Cleanup;
}
SEXP Random3(SEXP args)
{
if (!isVectorList(CAR(args))) error("incorrect usage");
SEXP x, a, b, c;
R_xlen_t i, n, na, nb, nc;
ran3 fn = rhyper; /* the only current example */
args = CDR(args);
if (!isVector(CAR(args))) error(_("invalid arguments"));
if (LENGTH(CAR(args)) == 1) {
#ifdef LONG_VECTOR_SUPPORT
double dn = asReal(CAR(args));
if (ISNAN(dn) || dn < 0 || dn > R_XLEN_T_MAX)
error(_("invalid arguments"));
n = (R_xlen_t) dn;
#else
n = asInteger(CAR(args));
if (n == NA_INTEGER || n < 0)
error(_("invalid arguments"));
#endif
}
else n = XLENGTH(CAR(args));
PROTECT(x = allocVector(INTSXP, n));
if (n == 0) {
UNPROTECT(1);
return(x);
}
args = CDR(args); a = CAR(args);
args = CDR(args); b = CAR(args);
args = CDR(args); c = CAR(args);
if (!isNumeric(a) || !isNumeric(b) || !isNumeric(c))
error(_("invalid arguments"));
na = XLENGTH(a);
nb = XLENGTH(b);
nc = XLENGTH(c);
if (na < 1 || nb < 1 || nc < 1) {
for (i = 0; i < n; i++) INTEGER(x)[i] = NA_INTEGER;
warning(_("NAs produced"));
}
else {
Rboolean naflag = FALSE;
PROTECT(a = coerceVector(a, REALSXP));
PROTECT(b = coerceVector(b, REALSXP));
PROTECT(c = coerceVector(c, REALSXP));
GetRNGstate();
double *ra = REAL(a), *rb = REAL(b), *rc = REAL(c), rx;
int *ix = INTEGER(x);
errno = 0;
for (R_xlen_t i = 0; i < n; i++) {
// if ((i+1) % NINTERRUPT) R_CheckUserInterrupt();
rx = fn(ra[i % na], rb[i % nb], rc[i % nc]);
if (ISNAN(rx) || rx > INT_MAX || rx <= INT_MIN) {
naflag = TRUE;
ix[i] = NA_INTEGER;
} else ix[i] = (int) rx;
}
if (naflag) warning(_("NAs produced"));
PutRNGstate();
UNPROTECT(3);
}
UNPROTECT(1);
return x;
}
void argmax_geno(int n_ind, int n_pos, int n_gen, int *geno,
double *rf, double *rf2,
double error_prob, int *argmax,
double initf(int),
double emitf(int, int, double),
double stepf(int, int, double, double))
{
int i, j, v, v2;
double s, t, *gamma, *tempgamma, *tempgamma2;
int **Geno, **Argmax, **traceback;
/* Read R's random seed */
/* in the case of multiple "most likely" genotype sequences,
we pick from them at random */
GetRNGstate();
/* allocate space and
reorganize geno and argmax */
reorg_geno(n_ind, n_pos, geno, &Geno);
reorg_geno(n_ind, n_pos, argmax, &Argmax);
allocate_imatrix(n_pos, n_gen, &traceback);
allocate_double(n_gen, &gamma);
allocate_double(n_gen, &tempgamma);
allocate_double(n_gen, &tempgamma2);
for(i=0; i<n_ind; i++) { /* i = individual */
R_CheckUserInterrupt(); /* check for ^C */
/* begin viterbi algorithm */
if(n_pos > 1) { /* multiple markers */
for(v=0; v<n_gen; v++)
gamma[v] = initf(v+1) + emitf(Geno[0][i], v+1, error_prob);
for(j=0; j<n_pos-1; j++) {
for(v=0; v<n_gen; v++) {
tempgamma[v] = s = gamma[0] + stepf(1, v+1, rf[j], rf2[j]);
traceback[j][v] = 0;
for(v2=1; v2<n_gen; v2++) {
t = gamma[v2] + stepf(v2+1, v+1, rf[j], rf2[j]);
if(t > s || (fabs(t-s) < TOL && unif_rand() < 0.5)) {
tempgamma[v] = s = t;
traceback[j][v] = v2;
}
}
tempgamma2[v] = tempgamma[v] + emitf(Geno[j+1][i], v+1, error_prob);
}
for(v=0; v<n_gen; v++) gamma[v] = tempgamma2[v];
}
/* finish off viterbi and then traceback to get most
likely sequence of genotypes */
Argmax[n_pos-1][i] = 0;
s = gamma[0];
for(v=1; v<n_gen; v++) {
if(gamma[v] > s || (fabs(gamma[v]-s) < TOL &&
unif_rand() < 0.5)) {
s = gamma[v];
Argmax[n_pos-1][i] = v;
}
}
for(j=n_pos-2; j >= 0; j--)
Argmax[j][i] = traceback[j][Argmax[j+1][i]];
}
else { /* for exactly one marker */
s = initf(1) + emitf(Geno[0][i], 1, error_prob);
Argmax[0][i] = 0;
for(v=1; v<n_gen; v++) {
t = initf(v+1)+emitf(Geno[0][i], v+1, error_prob);
if(t > s || (fabs(t-s) < TOL && unif_rand() < 0.5)) {
s = t;
Argmax[0][i] = v;
}
}
}
/* code genotypes as 1, 2, ... */
for(j=0; j<n_pos; j++) Argmax[j][i]++;
} /* loop over individuals */
/* write R's random seed */
PutRNGstate();
}
SEXP r2dtable(SEXP n, SEXP r, SEXP c)
{
int nr, nc, *row_sums, *col_sums, i, *jwork;
int n_of_samples, n_of_cases;
double *fact;
SEXP ans, tmp;
const void *vmax = vmaxget();
nr = length(r);
nc = length(c);
/* Note that the R code in r2dtable() also checks for missing and
negative values.
Should maybe do the same here ...
*/
if(!isInteger(n) || (length(n) == 0) ||
!isInteger(r) || (nr <= 1) ||
!isInteger(c) || (nc <= 1))
error(_("invalid arguments"));
n_of_samples = INTEGER(n)[0];
row_sums = INTEGER(r);
col_sums = INTEGER(c);
/* Compute total number of cases as the sum of the row sums.
Note that the R code in r2dtable() also checks whether this is
the same as the sum of the col sums.
Should maybe do the same here ...
*/
n_of_cases = 0;
jwork = row_sums;
for(i = 0; i < nr; i++)
n_of_cases += *jwork++;
/* Log-factorials from 0 to n_of_cases.
(I.e., lgamma(1), ..., lgamma(n_of_cases + 1).)
*/
fact = (double *) R_alloc(n_of_cases + 1, sizeof(double));
fact[0] = 0.;
for(i = 1; i <= n_of_cases; i++)
fact[i] = lgammafn((double) (i + 1));
jwork = (int *) R_alloc(nc, sizeof(int));
PROTECT(ans = allocVector(VECSXP, n_of_samples));
GetRNGstate();
for(i = 0; i < n_of_samples; i++) {
PROTECT(tmp = allocMatrix(INTSXP, nr, nc));
rcont2(&nr, &nc, row_sums, col_sums, &n_of_cases, fact,
jwork, INTEGER(tmp));
SET_VECTOR_ELT(ans, i, tmp);
UNPROTECT(1);
}
PutRNGstate();
UNPROTECT(1);
vmaxset(vmax);
return(ans);
}
// [[Rcpp::export]]
SEXP rcpp_bcpM(SEXP pdata, SEXP pid, SEXP pmcmcreturn, SEXP pburnin, SEXP pmcmc,
SEXP pa, SEXP pw)
{
NumericMatrix data(pdata);
int mcmcreturn = INTEGER_DATA(pmcmcreturn)[0];
int burnin = INTEGER_DATA(pburnin)[0];
int mcmc = INTEGER_DATA(pmcmc)[0];
// INITIALIZATION OF LOCAL VARIABLES
int i, j, m, k;
double wstar, xmax;
// INITIALIZATION OF OTHER OBJECTS
HelperVariables helpers(data, pid);
Params params(pw, helpers.cumksize.size(), data.nrow(), pa, false, false,
0, 0, data.ncol());
//params.print();
//helpers.print();
int MM = burnin + mcmc;
//helpers.print();
//params.print();
MCMCStepSeq step(helpers, params);
int MM2, nn2;
if (mcmcreturn == 0) {
MM2 = 1;
nn2 = 1;
} else {
nn2 = params.nn;
MM2 = MM;
}
// Things to be returned to R:
NumericMatrix pmean(params.nn, params.kk);
NumericMatrix ss(params.nn, params.kk);
NumericMatrix pvar(params.nn, params.kk);
NumericVector pchange(params.nn);
NumericVector blocks(burnin + mcmc);
NumericMatrix rhos(nn2, MM2);
// NumericVector liks(MM2);
NumericMatrix results(nn2*MM2,params.kk);
double tmpMean;
// Rprintf("starting\n");
GetRNGstate(); // Consider Dirk's comment on this.
// step.print();
for (i = 0; i < params.nn; i++) {
pchange[i] = 0;
for (j = 0; j < params.kk; j++) {
pmean(i, j) = 0;
}
}
for (m = 0; m < MM; m++) {
// Rprintf("Step %d -- ", m);
step = pass(step, helpers, params);
// Rprintf("blocks:%d, B:%0.2f\n", step.b, step.B);
blocks[m] = step.b;
if (m >= burnin || mcmcreturn == 1) {
// compute posteriors
if (step.B == 0) {
wstar = params.w[0] * (step.b*params.kk + 1) / (step.b * params.kk +3);
} else {
xmax = step.B * params.w[0] / step.W / (1 + step.B * params.w[0] / step.W);
// Rprintf("xmax:%0.2f\n", xmax);
// wstar = log(step.W) - log(step.B)
// + Rf_lbeta((double) (step.b* params.kk + 3) / 2, (double) ((params.nn2 - step.b)*params.kk - 4) / 2)
// + Rf_pbeta(xmax, (double) (step.b*params.kk + 3) / 2, (double) ((params.nn2 - step.b)*params.kk - 4) / 2, 1, 1)
// - Rf_lbeta((double) (step.b*params.kk + 1) / 2, (double) ((params.nn2 - step.b)*params.kk - 2) / 2)
// - Rf_pbeta(xmax, (double) (step.b * params.kk+ 1) / 2, (double) ((params.nn2 - step.b)*params.kk - 2) / 2, 1, 1);
// wstar = exp(wstar);
wstar = (step.W/step.B)*
Rf_beta((double) (step.b* params.kk + 3) / 2, (double) ((params.nn2 - step.b)*params.kk - 4) / 2) *
Rf_pbeta(xmax, (double) (step.b*params.kk + 3) / 2, (double) ((params.nn2 - step.b)*params.kk - 4) / 2, 1, 0) /
Rf_beta((double) (step.b*params.kk + 1) / 2, (double) ((params.nn2 - step.b)*params.kk - 2) / 2) /
Rf_pbeta(xmax, (double) (step.b * params.kk+ 1) / 2, (double) ((params.nn2 - step.b)*params.kk - 2) / 2, 1, 0);
// Rprintf("wstar:%0.2f\n", wstar);
}
// for posterior estimate of overall noise variance
// if (m >= burnin)
// pvar += (step.W + wstar*step.B)/(params.nn2 * params.kk-3);
k = 0;
for (j = 0; j < params.nn; j++) {
// Rprintf("j:%d out of %d (%d, %d) | ", j, params.nn, pchange.size(), step.rho.size());
// Rprintf("pchange[%d]: %0.2f, step.rho:%d\n", j, pchange[j], step.rho[j]);
if (m >= burnin)
pchange[j] += (double) step.rho[j];
for (i = 0; i < params.kk; i++) {
tmpMean = step.bmean[k][i] * (1 - wstar) + helpers.ybar * wstar;
// Rprintf("i:%d -- tmpMean:%0.2f, wstar:%0.2f, bmean:%0.2f, ybar:%0.2f\n",
// i, tmpMean, wstar, step.bmean[k][i], helpers.ybar);
if (m >= burnin) {
pmean(j, i) += tmpMean;
ss(j, i) += tmpMean * tmpMean;
// Rprintf("pmean:%0.2f, ss:%0.2f\n", pmean(j,i), ss(j,i));
}
if (mcmcreturn == 1)
results(m*params.nn+j, i) = tmpMean;
}
if (mcmcreturn == 1)
rhos(j, m) = step.rho[j];
if (step.rho[j] == 1) k++;
}
}
}
// Rprintf("post processing\n");
// step.print();
// post processing
for (j = 0; j < params.nn; j++) {
pchange[j] /= mcmc;
for (i = 0; i < params.kk; i++) {
pmean(j, i) /= mcmc;
pvar(j, i) = (ss(j, i) / mcmc - pmean(j,i)*pmean(j,i))*(mcmc/(mcmc-1));
}
}
// Rprintf("ending\n");
PutRNGstate();
List z;
z["posterior.mean"] = pmean;
z["posterior.var"] = pvar;
z["posterior.prob"] = pchange;
z["blocks"] = blocks;
z["mcmc.rhos"] = rhos;
z["mcmc.means"] = results;
// z["lik"] = liks;
return z;
} /* END MAIN */
SEXP Random1(SEXP args)
{
if (!isVectorList(CAR(args))) error("incorrect usage");
SEXP x, a;
R_xlen_t i, n, na;
ran1 fn = NULL; /* -Wall */
const char *dn = CHAR(STRING_ELT(getListElement(CAR(args), "name"), 0));
SEXPTYPE type = REALSXP;
if (streql(dn, "rchisq")) fn = &rchisq;
else if (streql(dn, "rexp")) fn = &rexp;
else if (streql(dn, "rgeom")) {
type = INTSXP;
fn = &rgeom;
} else if (streql(dn, "rpois")) {
type = INTSXP;
fn = &rpois;
}
else if (streql(dn, "rt")) fn = &rt;
else if (streql(dn, "rsignrank")) {
type = INTSXP;
fn = &rsignrank;
}
else error(_("invalid arguments"));
args = CDR(args);
if (!isVector(CAR(args)) || !isNumeric(CADR(args)))
error(_("invalid arguments"));
if (XLENGTH(CAR(args)) == 1) {
#ifdef LONG_VECTOR_SUPPORT
double dn = asReal(CAR(args));
if (ISNAN(dn) || dn < 0 || dn > R_XLEN_T_MAX)
error(_("invalid arguments"));
n = (R_xlen_t) dn;
#else
n = asInteger(CAR(args));
if (n == NA_INTEGER || n < 0)
error(_("invalid arguments"));
#endif
}
else n = XLENGTH(CAR(args));
PROTECT(x = allocVector(type, n));
if (n == 0) {
UNPROTECT(1);
return(x);
}
na = XLENGTH(CADR(args));
if (na < 1) {
if (type == INTSXP)
for (i = 0; i < n; i++) INTEGER(x)[i] = NA_INTEGER;
else
for (i = 0; i < n; i++) REAL(x)[i] = NA_REAL;
warning(_("NAs produced"));
} else {
Rboolean naflag = FALSE;
PROTECT(a = coerceVector(CADR(args), REALSXP));
GetRNGstate();
double *ra = REAL(a);
errno = 0;
if (type == INTSXP) {
double rx;
int *ix = INTEGER(x);
for (R_xlen_t i = 0; i < n; i++) {
// if ((i+1) % NINTERRUPT) R_CheckUserInterrupt();
rx = fn(ra[i % na]);
if (ISNAN(rx) || rx > INT_MAX || rx <= INT_MIN ) {
naflag = TRUE;
ix[i] = NA_INTEGER;
}
else ix[i] = (int) rx;
}
} else {
double *rx = REAL(x);
for (R_xlen_t i = 0; i < n; i++) {
// if ((i+1) % NINTERRUPT) R_CheckUserInterrupt();
rx[i] = fn(ra[i % na]);
if (ISNAN(rx[i])) naflag = TRUE;
}
}
if (naflag) warning(_("NAs produced"));
PutRNGstate();
UNPROTECT(1);
}
UNPROTECT(1);
return x;
}
void arsaRawParallel(arsaRawArgs& args)
{
long n = args.n;
Rbyte* rawDist = args.rawDist;
std::vector<double>& levels = args.levels;
double cool = args.cool;
double temperatureMin = args.temperatureMin;
if(temperatureMin <= 0)
{
throw std::runtime_error("Input temperatureMin must be positive");
}
long nReps = args.nReps;
std::vector<int>& permutation = args.permutation;
std::function<void(unsigned long, unsigned long)> progressFunction = args.progressFunction;
bool randomStart = args.randomStart;
int maxMove = args.maxMove;
if(maxMove < 0)
{
throw std::runtime_error("Input maxMove must be non-negative");
}
double effortMultiplier = args.effortMultiplier;
if(effortMultiplier <= 0)
{
throw std::runtime_error("Input effortMultiplier must be positive");
}
permutation.resize(n);
if(n == 1)
{
permutation[0] = 0;
return;
}
else if(n < 1)
{
throw std::runtime_error("Input n must be positive");
}
//We skip the initialisation of D, R1 and R2 from arsa.f, and the computation of asum.
//Next the original arsa.f code creates nReps random permutations, and holds them all at once. This doesn't seem necessary, we create them one at a time and discard them
double zbestAllReps = -std::numeric_limits<double>::infinity();
//A copy of the best permutation found
std::vector<int> bestPermutationThisRep(n);
//We use this to build the random permutations
std::vector<int> consecutive(n);
for(R_xlen_t i = 0; i < n; i++) consecutive[i] = (int)i;
std::vector<int> deltaComponents(levels.size());
//We're doing lots of simulation, so we use the old-fashioned approach to dealing with Rs random number generation
GetRNGstate();
std::vector<change> stackOfChanges;
std::vector<bool> dirty(n, false);
for(int repCounter = 0; repCounter < nReps; repCounter++)
{
//create the random permutation, if we decided to use a random initial permutation
if(randomStart)
{
for(R_xlen_t i = 0; i < n; i++)
{
double rand = unif_rand();
R_xlen_t index = (R_xlen_t)(rand*(n-i));
if(index == n-i) index--;
bestPermutationThisRep[i] = consecutive[index];
std::swap(consecutive[index], *(consecutive.rbegin()+i));
}
}
else
{
for(R_xlen_t i = 0; i < n; i++)
{
bestPermutationThisRep[i] = consecutive[i];
}
}
//calculate value of z
double z = 0;
for(R_xlen_t i = 0; i < n-1; i++)
{
R_xlen_t k = bestPermutationThisRep[i];
for(R_xlen_t j = i+1; j < n; j++)
{
R_xlen_t l = bestPermutationThisRep[j];
z += (j-i) * levels[rawDist[l*n + k]];
}
}
double zbestThisRep = z;
double temperatureMax = 0;
//Now try 5000 random swaps
for(R_xlen_t swapCounter = 0; swapCounter < (R_xlen_t)(5000*effortMultiplier); swapCounter++)
{
R_xlen_t swap1, swap2;
getPairForSwap(n, swap1, swap2);
double delta = computeDelta(bestPermutationThisRep, swap1, swap2, rawDist, levels, deltaComponents);
if(delta < 0)
{
if(fabs(delta) > temperatureMax) temperatureMax = fabs(delta);
}
}
double temperature = temperatureMax;
std::vector<int> currentPermutation = bestPermutationThisRep;
int nloop = (int)((log(temperatureMin) - log(temperatureMax)) / log(cool));
long totalSteps = (long)(nloop * 100 * n * effortMultiplier);
long done = 0;
//Rcpp::Rcout << "Steps needed: " << nloop << std::endl;
for(R_xlen_t idk = 0; idk < nloop; idk++)
{
//Rcpp::Rcout << "Temp = " << temperature << std::endl;
for(R_xlen_t k = 0; k < (R_xlen_t)(100*n*effortMultiplier); k++)
{
R_xlen_t swap1, swap2;
//swap
if(unif_rand() <= 0.5)
{
getPairForSwap(n, swap1, swap2);
change newChange;
newChange.isMove = false;
newChange.swap1 = swap1; newChange.swap2 = swap2;
if(dirty[swap1] || dirty[swap2])
{
#pragma omp parallel for
for(std::vector<change>::iterator i = stackOfChanges.begin(); i != stackOfChanges.end(); i++)
{
deltaForChange(*i, currentPermutation, rawDist, levels);
}
for(std::vector<change>::iterator i = stackOfChanges.begin(); i != stackOfChanges.end(); i++)
{
makeChange(*i, currentPermutation, rawDist, levels, z, zbestThisRep, bestPermutationThisRep, temperature);
}
done += stackOfChanges.size();
progressFunction(done, totalSteps);
stackOfChanges.clear();
std::fill(dirty.begin(), dirty.end(), false);
}
else dirty[swap1] = dirty[swap2] = true;
stackOfChanges.push_back(newChange);
}
//insertion
else
{
getPairForMove(n, swap1, swap2, maxMove);
bool canDefer = true;
for(R_xlen_t i = std::min(swap1, swap2); i != std::max(swap1, swap2)+1; i++) canDefer &= !dirty[i];
change newChange;
newChange.isMove = true;
newChange.swap1 = swap1;
newChange.swap2 = swap2;
if(canDefer)
{
std::fill(dirty.begin() + std::min(swap1, swap2), dirty.begin() + std::max(swap1, swap2)+1, true);
}
else
{
#pragma omp parallel for
for(std::vector<change>::iterator i = stackOfChanges.begin(); i != stackOfChanges.end(); i++)
{
deltaForChange(*i, currentPermutation, rawDist, levels);
}
for(std::vector<change>::iterator i = stackOfChanges.begin(); i != stackOfChanges.end(); i++)
{
makeChange(*i, currentPermutation, rawDist, levels, z, zbestThisRep, bestPermutationThisRep, temperature);
}
done += stackOfChanges.size();
progressFunction(done, totalSteps);
stackOfChanges.clear();
std::fill(dirty.begin(), dirty.end(), false);
}
stackOfChanges.push_back(newChange);
}
}
#pragma omp parallel for
for(std::vector<change>::iterator i = stackOfChanges.begin(); i != stackOfChanges.end(); i++)
{
deltaForChange(*i, currentPermutation, rawDist, levels);
}
for(std::vector<change>::iterator i = stackOfChanges.begin(); i != stackOfChanges.end(); i++)
{
makeChange(*i, currentPermutation, rawDist, levels, z, zbestThisRep, bestPermutationThisRep, temperature);
}
done += stackOfChanges.size();
progressFunction(done, totalSteps);
stackOfChanges.clear();
std::fill(dirty.begin(), dirty.end(), false);
temperature *= cool;
}
if(zbestThisRep > zbestAllReps)
{
zbestAllReps = zbestThisRep;
permutation.swap(bestPermutationThisRep);
}
}
PutRNGstate();
}
void isevect(double *t, int *delta, int *n, int *nboot, double *gridise, int *legridise, double *gridbw1, int *legridbw1, double *gridbw2, int *legridbw2, int *nkernel, int * dup, int *nestimand, double *phat, double *estim, int* presmoothing, double *isev){
int i, j, k, boot, *indices, *deltaboot, *pnull;
double *pnull2, *ptemp, *estimboot, *tboot, *integrand, *isecomp, *deltabootdbl;
indices = malloc(*n * sizeof(int));
ptemp = malloc(*n * sizeof(double));
estimboot = malloc(*legridise * sizeof(double));
tboot = malloc(*n * sizeof(double));
integrand = malloc(*legridise * sizeof(double));
isecomp = malloc(sizeof(double));
GetRNGstate();
if(*presmoothing == 1){ // with presmoothing
deltaboot = malloc(*n * sizeof(int));
switch(*nestimand){
// S
case 1:
pnull = calloc(1, sizeof(int));
pnull2 = calloc(1, sizeof(double));
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmestim(gridise, legridise, tboot, n, pnull2, pnull, pnull, ptemp, pnull, nestimand, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
free(pnull);
free(pnull2);
break;
// H
case 2:
pnull = calloc(1, sizeof(int));
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmestim(gridise, legridise, tboot, n, gridbw2, nkernel, pnull, ptemp, dup, nestimand, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
free(pnull);
break;
// f
case 3:
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (j = 0; j < *legridbw2; j++)
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmdensfast(gridise, legridise, tboot, n, &(gridbw2[j]), nkernel, ptemp, estimboot);
for (k = 0; k < *legridise; k++)
integrand[k] = (estimboot[k] - estim[k])*(estimboot[k] - estim[k]);
simpson(integrand, legridise, isecomp);
isev[j * (*legridbw1) + i] += *isecomp;
}
}
break;
// h
case 4:
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (j = 0; j < *legridbw2; j++)
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmtwfast(gridise, legridise, tboot, n, &(gridbw2[j]), nkernel, dup, ptemp, estimboot);
for (k = 0; k < *legridise; k++)
integrand[k] = (estimboot[k] - estim[k])*(estimboot[k] - estim[k]);
simpson(integrand, legridise, isecomp);
isev[j * (*legridbw1) + i] += *isecomp;
}
}
break;
default:
break;
}
free(deltaboot);
}
else{ // without presmoothing
deltabootdbl = malloc(*n * sizeof(double));
if(*nestimand == 3){
// f
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltabootdbl[i] = (double)delta[indices[i]];
}
for (i = 0; i < *legridbw2; i++){
presmdensfast(gridise, legridise, tboot, n, &(gridbw2[i]), nkernel, deltabootdbl, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
}
else{
// h
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltabootdbl[i] = (double)delta[indices[i]];
}
for (i = 0; i < *legridbw2; i++){
presmtwfast(gridise, legridise, tboot, n, &(gridbw2[i]), nkernel, dup, deltabootdbl, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
}
free(deltabootdbl);
}
PutRNGstate();
free(indices);
free(ptemp);
free(estimboot);
free(tboot);
free(integrand);
free(isecomp);
}
