void twosample_ks_cm_ad(double *time, int *event, int *group, int *n, double *rho, double *gamma,
int *nsim, int *nperm, int *nboot, double *du, int *nsim_plot, int *nperm_plot, int *nboot_plot,
double *du_sim_plot, double *du_perm_plot, double *du_boot_plot,
double *stat_ks_w, double *pval_ks_w_sim, double *pval_ks_w_perm, double *pval_ks_w_boot, double *pval_ks_w_asympt,
double *stat_ks_b, double *pval_ks_b_sim, double *pval_ks_b_perm, double *pval_ks_b_boot, double *pval_ks_b_asympt,
double *stat_cm_w, double *pval_cm_w_sim, double *pval_cm_w_perm, double *pval_cm_w_boot,
double *stat_cm_b, double *pval_cm_b_sim, double *pval_cm_b_perm, double *pval_cm_b_boot,
double *stat_ad_w, double *pval_ad_w_sim, double *pval_ad_w_perm, double *pval_ad_w_boot,
double *stat_ad_b, double *pval_ad_b_sim, double *pval_ad_b_perm, double *pval_ad_b_boot)
{
int i,j,k,r;
int y1,y2,y1bak,y2bak,first_event,first_event_g;
double temp1,temp2,temp3,temp4,temp5,temp6;
/* various work arrays of length n */
double *dsigma; /* increments of variance */
double *ks_b; /* weight for KS for Brownian bridge */
double *cm_w,*cm_b,*ad_w,*ad_b; /* integrators for CM and AD for Brownian motion (.w) and bridge (.b) */
double *g; /* normal random numbers for LWY simulation */
double *du_temp; /* increments of simulated, permutation or bootstrap test process */
int *eventg; /* bootstrap sample */
int *freqg; /* bootstrap sample frequencies */
GetRNGstate();
/* allocate everything at once */
dsigma = (double *) R_alloc(7*(*n),sizeof(double)); /* 6*n, not 7*n, because cm.w is dsigma */
ks_b = dsigma + *n;
cm_w = dsigma;
cm_b = dsigma + *n*2;
ad_w = dsigma + *n*3;
ad_b = dsigma + *n*4;
g = dsigma + *n*5;
du_temp = dsigma + *n*6;
/* initialise at-risk values */
y1 = 0;
y2 = 0;
for (i=0; i<*n; i++) {
if (group[i] == 1) {
++y1;
} else {
++y2;
}
}
y1bak = y1;
y2bak = y2;
/* find the first event (needed in AD test to avoid division by zero) */
for (first_event=0; (event[first_event]==0)&&(first_event<*n) ; first_event++)
;
/* compute the OBSERVED process and statistics (g is 1) */
ks_cm_ad_process(event, group, n, &y1, &y2, rho, gamma, &first_event, du, dsigma, ks_b, cm_w, cm_b, ad_w, ad_b);
y1 = y1bak;
y2 = y2bak;
for (i=0; i<*n; i++)
g[i] = 1.;
ks_cm_ad_stat(n,du,g,ks_b,cm_w,cm_b,ad_w,ad_b,stat_ks_w,stat_ks_b,stat_cm_w,stat_cm_b,stat_ad_w,stat_ad_b);
/* now do the true LWY SIMULATIONS (g is random) */
/* LWY must be done before permutations and bootstrap (permutations and bootstrap destroy group) */
*pval_ks_w_sim = *pval_ks_b_sim = *pval_cm_w_sim = *pval_cm_b_sim = *pval_ad_w_sim = *pval_ad_b_sim = 0.;
if (*nsim>0) {
for (j=0; j<*nsim; j++) {
for (i=0; i<*n; i++) {
g[i] = norm_rand();
}
/* store this LWY-simulated process for plotting */
if (j<*nsim_plot) {
for (i=0; i<*n; i++)
du_sim_plot[i+j**n] = g[i]*du[i];
}
ks_cm_ad_stat(n,du,g,ks_b,cm_w,cm_b,ad_w,ad_b,&temp1,&temp2,&temp3,&temp4,&temp5,&temp6);
*pval_ks_w_sim += (temp1>*stat_ks_w);
*pval_ks_b_sim += (temp2>*stat_ks_b);
*pval_cm_w_sim += (temp3>*stat_cm_w);
*pval_cm_b_sim += (temp4>*stat_cm_b);
*pval_ad_w_sim += (temp5>*stat_ad_w);
*pval_ad_b_sim += (temp6>*stat_ad_b);
}
*pval_ks_w_sim /= (double) *nsim;
*pval_ks_b_sim /= (double) *nsim;
*pval_cm_w_sim /= (double) *nsim;
*pval_cm_b_sim /= (double) *nsim;
*pval_ad_w_sim /= (double) *nsim;
*pval_ad_b_sim /= (double) *nsim;
}
/* BOOTSTRAP */
*pval_ks_w_boot = *pval_ks_b_boot = *pval_cm_w_boot = *pval_cm_b_boot = *pval_ad_w_boot = *pval_ad_b_boot = 0.;
for (i=0; i<*n; i++)
g[i] = 1.;
if (*nboot>0) {
/* allocate arrays for the bootstrap sample */
eventg = (int *) R_alloc(2**n,sizeof(int));
freqg = eventg + *n;
for (i=0; i<*nboot; i++) {
/* compute frequencies of the original data in the bootstrap sample (we want to avoid sorting the bootstrap sample) */
for (j=0; j<*n; j++)
freqg[j] = 0;
for (j=0; j<*n; j++) { /* n times randomly select an index and increase its frequency */
r = (unif_rand()**n);
freqg[r] += 1;
}
/* now take corresponding number of observations from the data */
r = 0;
for (j=0; j<*n; j++) {
for (k=0; k<freqg[j]; k++) { /* put the j-th observation freqg[j]-times to the bootstrap sample */
eventg[r] = event[j];
++r;
}
}
for (first_event_g=0; (event[first_event_g]==0)&&(first_event_g<*n) ; first_event_g++)
;
for (j=0; j<*n; j++) { /* each observation is randomly assigned to one of the groups; group from input is reused */
if (unif_rand() < ((double) y1/(y1+y2))) {
group[j] = 1;
--y1;
} else {
group[j] = 2;
--y2;
}
}
y1 = y1bak;
y2 = y2bak;
ks_cm_ad_process(eventg, group, n, &y1, &y2, rho, gamma, &first_event_g, du_temp, dsigma, ks_b, cm_w, cm_b, ad_w, ad_b);
/* store this bootstrapped process for plotting */
if (i<*nboot_plot) {
for (j=0; j<*n; j++)
du_boot_plot[j+i**n] = du_temp[j];
}
y1 = y1bak;
y2 = y2bak;
ks_cm_ad_stat(n,du_temp,g,ks_b,cm_w,cm_b,ad_w,ad_b,&temp1,&temp2,&temp3,&temp4,&temp5,&temp6);
*pval_ks_w_boot += (temp1>*stat_ks_w);
*pval_ks_b_boot += (temp2>*stat_ks_b);
*pval_cm_w_boot += (temp3>*stat_cm_w);
*pval_cm_b_boot += (temp4>*stat_cm_b);
*pval_ad_w_boot += (temp5>*stat_ad_w);
*pval_ad_b_boot += (temp6>*stat_ad_b);
}
*pval_ks_w_boot /= (double) *nboot;
*pval_ks_b_boot /= (double) *nboot;
*pval_cm_w_boot /= (double) *nboot;
*pval_cm_b_boot /= (double) *nboot;
*pval_ad_w_boot /= (double) *nboot;
*pval_ad_b_boot /= (double) *nboot;
}
/* PERMUTATION tests (g is 1) */
*pval_ks_w_perm = *pval_ks_b_perm = *pval_cm_w_perm = *pval_cm_b_perm = *pval_ad_w_perm = *pval_ad_b_perm = 0.;
for (i=0; i<*n; i++)
g[i] = 1.;
if (*nperm>0) {
for (i=0; i<*nperm; i++) {
for (j=0; j<*n; j++) { /* each observation is randomly assigned to one of the groups; group from input is reused (destroyed) */
if (unif_rand() < ((double) y1/(y1+y2))) {
group[j] = 1;
--y1;
} else {
group[j] = 2;
--y2;
}
}
y1 = y1bak;
y2 = y2bak;
ks_cm_ad_process(event, group, n, &y1, &y2, rho, gamma, &first_event, du_temp, dsigma, ks_b, cm_w, cm_b, ad_w, ad_b);
/* store this permutation process for plotting */
if (i<*nperm_plot) {
for (j=0; j<*n; j++)
du_perm_plot[j+i**n] = du_temp[j];
}
y1 = y1bak;
y2 = y2bak;
ks_cm_ad_stat(n,du_temp,g,ks_b,cm_w,cm_b,ad_w,ad_b,&temp1,&temp2,&temp3,&temp4,&temp5,&temp6);
*pval_ks_w_perm += (temp1>*stat_ks_w);
*pval_ks_b_perm += (temp2>*stat_ks_b);
*pval_cm_w_perm += (temp3>*stat_cm_w);
*pval_cm_b_perm += (temp4>*stat_cm_b);
*pval_ad_w_perm += (temp5>*stat_ad_w);
*pval_ad_b_perm += (temp6>*stat_ad_b);
}
*pval_ks_w_perm /= (double) *nperm;
*pval_ks_b_perm /= (double) *nperm;
*pval_cm_w_perm /= (double) *nperm;
*pval_cm_b_perm /= (double) *nperm;
*pval_ad_w_perm /= (double) *nperm;
*pval_ad_b_perm /= (double) *nperm;
}
/* ASYMPTOTIC p-values of KS */
*pval_ks_w_asympt = 1. - psupw(*stat_ks_w,50);
*pval_ks_b_asympt = 1. - psupb(*stat_ks_b,.5,50);
PutRNGstate();
}
void SimOneMVN_mxIW(double *nu, double *Lbdinvhlf, double *f1f2, int *pd,
int *pnreps, int *pN, double *es, double *YY)
{
int i, j, k, l, d, d2, N, nreps, mxnreps, Jrand;
int *lbuff;
double xd, sm, tstnu, nu_1, nu_2, zz, lambda, f_1, f_2;
double *df, *pW, *SgmHlf, *Y, *xbuff, *Sigma, *sig, *SigInv;
N = *pN;
d = *pd;
xd = (double) d;
d2 = d*d;
mxnreps=0;
for(l=0;l<N;l++) if(mxnreps < *(pnreps+l)) mxnreps = *(pnreps+l);
lbuff = (int *)S_alloc( 1,sizeof(int));
df = (double *)S_alloc( 1, sizeof(double));
pW = (double *)S_alloc( d2, sizeof(double));
xbuff = (double *)S_alloc( d, sizeof(double));
SgmHlf = (double *)S_alloc( d2, sizeof(double));
Y = (double *)S_alloc(mxnreps*d, sizeof(double));
Sigma = (double *)S_alloc( d2, sizeof(double));
SigInv = (double *)S_alloc( d2, sizeof(double));
sig = (double *)S_alloc( d, sizeof(double));
f_1 = *f1f2;
f_2 = *(f1f2+1);
lambda = *nu/(2 * xd + 2.0);
nu_1 = (2.0 * xd + 2.0)*(1.0 + (lambda - 1.0) *(1.0 - f_1)/(1-f_1/f_2));
nu_2 = (2.0 * xd + 2.0)*(1.0 + (lambda - 1.0) * f_2 );
tstnu = f_1/(nu_2 - (2.0*xd+2.0)) + (1.0-f_1)/(nu_1 - (2.0*xd+2.0));
tstnu = 1.0/tstnu + 2.0*xd + 2.0;
Rprintf("nu_1=%g, nu_2=%g, nu ?= %g", nu_1, nu_2, tstnu);
GetRNGstate();
/* NOTE: */
/* this block computes the average std dev over genes from the model */
/* its diagonal elements, passed to the pointer, sig (of size 3) */
/* are used for the purposes of assigning mean value to Y's under the alternative */
/* */
for(i=0;i<d;i++)
for(j=0;j<d;j++){
sm = 0.0;
for(k=0;k<d;k++)
sm += *(Lbdinvhlf + d*i + k) * (*(Lbdinvhlf + d*j + k));
*(SigInv + d*j + i) = sm;
}
matinv(SigInv, Sigma, pd);
for(i=0;i<d;i++) *(sig + i) = pow((*(Sigma + d*i + i))/(*nu - 2.0*xd - 2.0), 0.5);
for(l=0;l<N;l++){
/* Pick J = 1 w.p. 1-f_1, J= 2 w.p. f_1. */
/* Then draw an InvWish_d(nu_J, Lambda) matrix. This is done */
/* using the result: if Sigma^(-1) ~ Wish_d(nu-d-1, Lambda^(-1)) then */
/* Sigma ~ InvWish_d(nu, Lambda). I simulate N i.i.d. Wish_d(nu-d-1,Lambda^(-1)) */
/* matrices and then invert to get Sigma. One more catch, my rwishart routine */
/* uses the cholesky square root of the parameter matrix, Lambda instead of Lambda */
/* itself. Since I want the parameter matrix in the Wishart to be Lambda^(-1) then */
/* I should pass its cholesky square root which is Lbdinvhlf, e.g. the cholesky */
/* square root of Lambda inverse. That is computed in the calling R script and */
/* passed in. Notice the need to check that Lambda is nonsingular and that */
/* nu > 2*d + 2 (required so that the expected value of the inverse wishart */
/* is finite.) */
/* */
zz = unif_rand();
Jrand = 1*(zz < f_1);
*df = (1-Jrand)*nu_1 + Jrand*nu_2 - xd - 1.0;
rwishart1(df, pd, Lbdinvhlf, pW);
matinv(pW, Sigma, pd);
/* */
/* Sigma ~ (1-f_1)*InvWish_d(nu_1, Lambda) + f_1*InvWish_d(nu_2, Lambda) */
/* */
/* Next, use Sigma to simulate i.i.d. N(0_d, Sigma)'s */
nreps = *(pnreps + l);
*lbuff = nreps*d;
rnormn(lbuff, Y);
chol(Sigma, SgmHlf, pd);
for(i=0;i<nreps;i++){
for(j=0;j<d;j++){
sm = 0.0;
for(k=0;k<d;k++) sm += (*(SgmHlf +d*j +k))*(*(Y +d*i +k));
*(xbuff+j) = sm;
}
for(j=0;j<d;j++) *(Y + d*i + j) = *(xbuff + j) + *(es + l)*(*(sig + j));
}
for(i=0;i<(nreps*d);i++) *(YY + mxnreps*d*l + i) = *(Y+i);
}
PutRNGstate();
}
void circemb(int *nsim, int *ngrid, double *steps, int *dim, int *covmod,
double *nugget, double *sill, double *range, double *smooth,
double *ans){
int i, j, k = -1, r, nbar = *ngrid * *ngrid, m;
//irho is the imaginary part of the covariance -> 0
double *rho, *irho;
const double zero = 0;
//Below is a table of highly composite numbers
int HCN[39] = {1, 2, 4, 6, 12, 24, 36, 48, 60, 120, 180, 240,
360, 720, 840, 1260, 1680, 2520, 5040, 7560,
10080, 15120, 20160, 25200, 27720, 45360, 50400,
55440, 83160, 110880, 166320, 221760, 277200,
332640, 498960, 554400, 665280, 720720, 1081080};
/* Find the smallest size m for the circulant embedding matrix */
{
int dummy = 2 * (*ngrid - 1);
do {
k++;
m = HCN[k];
} while (m < dummy);
}
/* ---------- beginning of the embedding stage ---------- */
int mbar = m * m, halfM = m / 2, notPosDef = 0;
do {
double *dist = malloc(mbar * sizeof(double));
notPosDef = 0;
//Computation of the distance
for (r=mbar;r--;){
i = r % m;
j = r / m;
if (i > halfM)
i -= m;
if (j > halfM)
j -= m;
dist[r] = hypot(steps[0] * i, steps[1] * j);
}
//Computations of the covariances
rho = (double *)R_alloc(mbar, sizeof(double));
irho = (double *)R_alloc(mbar, sizeof(double));
for (i=mbar;i--;)
irho[i] = 0;
switch (*covmod){
case 1:
whittleMatern(dist, mbar, zero, *sill, *range, *smooth, rho);
break;
case 2:
cauchy(dist, mbar, zero, *sill, *range, *smooth, rho);
break;
case 3:
powerExp(dist, mbar, zero, *sill, *range, *smooth, rho);
break;
case 4:
bessel(dist, mbar, *dim, zero, *sill, *range, *smooth, rho);
break;
}
/* Compute the eigen values to check if the circulant embbeding
matrix is positive definite */
/* Note : The next lines is only valid for 2d random fields. I
need to change if there are m_1 \neq m_2 as I suppose that m_1
= m_2 = m */
int maxf, maxp, *iwork;
double *work;
fft_factor(m, &maxf, &maxp);
work = (double *)R_alloc(4 * maxf, sizeof(double));
iwork = (int *)R_alloc(maxp, sizeof(int));
fft_work(rho, irho, m, m, 1, -1, work, iwork);
fft_factor(m, &maxf, &maxp);
work = (double *)R_alloc(4 * maxf, sizeof(double));
iwork = (int *)R_alloc(maxp, sizeof(int));
fft_work(rho, irho, 1, m, m, -1, work, iwork);
//Check if the eigenvalues are all positive
for (i=mbar;i--;){
notPosDef |= (rho[i] < 0) || (fabs(irho[i]) > 0.001);
}
if (notPosDef){
k++;
m = HCN[k];
halfM = m / 2;
mbar = m * m;
}
if (k > 30)
error("Impossible to embbed the covariance matrix");
free(dist);
} while (notPosDef);
/* --------- end of the embedding stage --------- */
/* Computation of the square root of the eigenvalues */
for (i=mbar;i--;){
rho[i] = sqrt(rho[i]);
irho[i] = 0;//No imaginary part
}
int mdag = m / 2 + 1, mdagbar = mdag * mdag;
double isqrtMbar = 1 / sqrt(mbar);
double *a = malloc(mbar * sizeof(double)),
*ia = malloc(mbar * sizeof(double));
GetRNGstate();
for (k=*nsim;k--;){
/* ---------- Simulation from \Lambda^1/2 Q* Z ------------ */
for (r=mdagbar;r--;){
/* Below is the procedure 5.2.4 in Wood and Chan */
//Computation of the cardinality of A(j)
int j1, j2,i = r % mdag, j = r / mdag;
double u, v;
int card = (i != 0) * (i != halfM) + 2 * (j != 0) * (j != halfM);
switch (card){
case 3:
//B(1) = {1}, B^c(1) = {2}
j1 = (m - i) + m * j;
j2 = i + m * (m - j);
u = norm_rand();
v = norm_rand();
a[j1] = ia[j1] = M_SQRT1_2 * rho[j1];
a[j1] *= u;
ia[j1] *= v;
a[j2] = ia[j2] = M_SQRT1_2 * rho[j2];
a[j2] *= u;
ia[j2] *= -v;
//B(2) = {1,2}, B^c(2) = {0}
j1 = (m - i) + m * (m - j);
j2 = i + m * j;
u = norm_rand();
v = norm_rand();
a[j1] = ia[j1] = M_SQRT1_2 * rho[j1];
a[j1]*= u;
ia[j1] *= v;
a[j2] = ia[j2] = M_SQRT1_2 * rho[j2];
a[j2]*= u;
ia[j2] *= -v;
break;
case 1:
//B(1) = 0, B^c(1) = {1}
j1 = i + m * j;
j2 = m - i + m * j;
u = norm_rand();
v = norm_rand();
a[j1] = ia[j1] = M_SQRT1_2 * rho[j1];
a[j1] *= u;
ia[j1] *= v;
a[j2] = ia[j2] = M_SQRT1_2 * rho[j2];
a[j2] *= u;
ia[j2] *= -v;
break;
case 2:
//B(1) = 0, B^c(1) = {2}
j1 = i + m * j;
j2 = i + m * (m - j);
u = norm_rand();
v = norm_rand();
a[j1] = ia[j1] = M_SQRT1_2 * rho[j1];
a[j1] *= u;
ia[j1] *= v;
a[j2] = ia[j2] = M_SQRT1_2 * rho[j2];
a[j2] *= u;
ia[j2] *= -v;
break;
case 0:
j1 = i + m * j;
a[j1] = rho[j1] * norm_rand();
ia[j1] = 0;
break;
}
}
/* ---------- Computation of Q \Lambda^1/2 Q* Z ------------ */
int maxf, maxp, *iwork;
double *work;
/* The next lines is only valid for 2d random fields. I need to
change if m_1 \neq m_2 as here I suppose that m_1 = m_2 = m */
fft_factor(m, &maxf, &maxp);
work = (double *)R_alloc(4 * maxf, sizeof(double));
iwork = (int *)R_alloc(maxp, sizeof(int));
fft_work(a, ia, m, m, 1, -1, work, iwork);
fft_factor(m, &maxf, &maxp);
work = (double *)R_alloc(4 * maxf, sizeof(double));
iwork = (int *)R_alloc(maxp, sizeof(int));
fft_work(a, ia, 1, m, m, -1, work, iwork);
for (i=nbar;i--;)
ans[i + k * nbar] = isqrtMbar * a[i % *ngrid + m * (i / *ngrid)];
}
PutRNGstate();
if (*nugget > 0){
int dummy = *nsim * nbar;
double sqrtNugget = sqrt(*nugget);
GetRNGstate();
for (i=dummy;i--;)
ans[i] += sqrtNugget * norm_rand();
PutRNGstate();
}
free(a); free(ia);
return;
}
/*****************
void MCMC_wrapper
Wrapper for a call from R.
and don't forget that tail -> head
*****************/
void MCMC_wrapper(int *dnumnets, int *nedges,
int *tails, int *heads,
int *dn, int *dflag, int *bipartite,
int *nterms, char **funnames,
char **sonames,
char **MHproposaltype, char **MHproposalpackage,
double *inputs, double *theta0, int *samplesize,
double *sample, int *burnin, int *interval,
int *newnetworktails,
int *newnetworkheads,
int *fVerbose,
int *attribs, int *maxout, int *maxin, int *minout,
int *minin, int *condAllDegExact, int *attriblength,
int *maxedges,
int *status){
int directed_flag;
Vertex n_nodes, nmax, bip;
/* Edge n_networks; */
Network nw[1];
Model *m;
MHproposal MH;
n_nodes = (Vertex)*dn;
/* n_networks = (Edge)*dnumnets; */
nmax = (Edge)abs(*maxedges);
bip = (Vertex)*bipartite;
GetRNGstate(); /* R function enabling uniform RNG */
directed_flag = *dflag;
m=ModelInitialize(*funnames, *sonames, &inputs, *nterms);
/* Form the network */
nw[0]=NetworkInitialize(tails, heads, nedges[0],
n_nodes, directed_flag, bip, 0, 0, NULL);
MH_init(&MH,
*MHproposaltype, *MHproposalpackage,
inputs,
*fVerbose,
nw, attribs, maxout, maxin, minout, minin,
*condAllDegExact, *attriblength);
*status = MCMCSample(&MH,
theta0, sample, *samplesize,
*burnin, *interval,
*fVerbose, nmax, nw, m);
MH_free(&MH);
/* Rprintf("Back! %d %d\n",nw[0].nedges, nmax); */
/* record new generated network to pass back to R */
if(*status == MCMC_OK && *maxedges>0 && newnetworktails && newnetworkheads)
newnetworktails[0]=newnetworkheads[0]=EdgeTree2EdgeList(newnetworktails+1,newnetworkheads+1,nw,nmax-1);
ModelDestroy(m);
NetworkDestroy(nw);
PutRNGstate(); /* Disable RNG before returning */
}
/* openMP is used*/
SEXP updateIndicesX(SEXP blocks, SEXP sneighbors, SEXP snneigh,
SEXP sk, SEXP sZ, SEXP scheck, SEXP sden)
{
if (TYPEOF(sneighbors) != INTSXP)
error("'neighbors' must be of type 'integer'.");
if (TYPEOF(snneigh) != INTSXP)
error("'nneigh' must be of type 'integer'.");
if (TYPEOF(sk) != INTSXP)
error("'k' must be of type 'integer'.");
if (TYPEOF(sZ) != INTSXP)
error("'Z' must be of type 'integer'.");
if (TYPEOF(scheck) != REALSXP)
error("'check' must be of type 'double'.");
if (TYPEOF(sden) != REALSXP)
error("'den' must be of type 'double'.");
int *neighbors = INTEGER(sneighbors);
int nneigh = asInteger(snneigh);
if (nneigh <= 0)
error("The number of neighbors must be positive.");
int k = asInteger(sk);
if (k <= 0)
error("The number of components must be positive.");
int *Z = INTEGER(sZ);
int ldZ = LENGTH(sZ) / k;
if (ldZ <= 0)
error("The leading dimension of 'Z' must be positive.");
int ldN = LENGTH(sneighbors) / nneigh;
if (ldN <= 0)
error("The leading dimension of 'neighbors' must be positive.");
int ldD = LENGTH(sden) / k;
if (ldD <= 0)
error("The leading dimension of 'den' must be positive.");
if (ldZ - 1 != ldN || ldZ - 1 != ldD || ldN != ldD)
error("The leading dimension of 'Z', 'neighbors' and 'den' do not match.");
int ldC = LENGTH(scheck) / k;
double *den = REAL(sden);
double *check = REAL(scheck);
int nblocks = LENGTH(blocks);
int b;
GetRNGstate();
for (b = 0; b < nblocks; b++) {
SEXP spoints = VECTOR_ELT(blocks, b);
int n = LENGTH(spoints);
int *points = INTEGER(spoints);
double *U = (double *) R_alloc(n, sizeof(double));
/*double *prob = (double *) R_alloc(k, sizeof(double));*/
/* int *Ni = (int *) R_alloc(k, sizeof(int));*/
int i;
for (i = 0; i < n; i++)
U[i] = unif_rand();
#pragma omp parallel for firstprivate(k, ldD, ldN, ldZ, ldC, nneigh, neighbors, \
Z, den, check, points, U)
for (i = 0; i < n; i++) {
int j, m;
double s = 0.0;
int number = 0;
double prob[10];
int Ni[10];
/* compute the posterior weights for the different classes */
for (j = 0; j < k; j++) {
Ni[j] = 0;
for (m = 0; m < nneigh; m++) {
int mm = neighbors[points[i] - 1 + m * ldN] - 1;
Ni[j] += Z[mm + j * ldZ];
}
}
/*compute the index to use the check table*/
for (j = 0; j < k; j++) {
number += Ni[j] * pow(nneigh+1, j);
}
for (j = 0; j < k; j++) {
/* use tabled value check[or + j*ldC] = exp(beta * Ni[j]) */
prob[j] = den[points[i] - 1 + j * ldD] * check[number + j * ldC];
s += prob[j];
}
/* fix up the weights and convert to probabilities */
if (s != 0.0 && R_FINITE(s))
for (j = 0; j < k; j++)
prob[j] = prob[j] / s;
else
for (j = 0; j < k; j++)
prob[j] = 1.0 / k;
/* generate new Z[points[i] - 1,] entries */
for (j = 0; j < k; j++)
Z[points[i] - 1 + j * ldZ] = 0;
for (m = 0, s = 0.0, j = 0; j < k - 1; j++) {
s += prob[j];
if (U[i] > s) m++;
}
Z[points[i] - 1 + m * ldZ] = 1;
}
}
PutRNGstate();
return sZ;
}
void rgeomdirect(double *coord, int *nObs, int *nSite, int *dim,
int *covmod, int *grid, double *sigma2, double *nugget,
double *range, double *smooth, double *uBound,
double *ans){
/* This function generates random fields for the geometric model
coord: the coordinates of the locations
nObs: the number of observations to be generated
nSite: the number of locations
dim: the random field is generated in R^dim
covmod: the covariance model
grid: Does coord specifies a grid?
sigma2: the variance of the geometric gaussian process
nugget: the nugget parameter
range: the range parameter
smooth: the smooth parameter
ans: the generated random field */
int i, j, neffSite, lagi = 1, lagj = 1, oneInt = 1;
const double loguBound = log(*uBound), halfSigma2 = 0.5 * *sigma2;
double sigma = sqrt(*sigma2), sill = 1 - *nugget;
if (*grid){
neffSite = R_pow_di(*nSite, *dim);
lagi = neffSite;
}
else{
neffSite = *nSite;
lagj = *nObs;
}
double *covmat = malloc(neffSite * neffSite * sizeof(double)),
*gp = malloc(neffSite * sizeof(double));
buildcovmat(nSite, grid, covmod, coord, dim, nugget, &sill, range,
smooth, covmat);
/* Compute the Cholesky decomposition of the covariance matrix */
int info = 0;
F77_CALL(dpotrf)("U", &neffSite, covmat, &neffSite, &info);
if (info != 0)
error("error code %d from Lapack routine '%s'", info, "dpotrf");
GetRNGstate();
for (i=*nObs;i--;){
double poisson = 0;
int nKO = neffSite;
while (nKO) {
/* The stopping rule is reached when nKO = 0 i.e. when each site
satisfies the condition in Eq. (8) of Schlather (2002) */
poisson += exp_rand();
double ipoisson = -log(poisson), thresh = loguBound + ipoisson;
/* We simulate one realisation of a gaussian random field with
the required covariance function */
for (j=neffSite;j--;)
gp[j] = norm_rand();
F77_CALL(dtrmv)("U", "T", "N", &neffSite, covmat, &neffSite, gp, &oneInt);
nKO = neffSite;
double ipoissonMinusHalfSigma2 = ipoisson - halfSigma2;
for (j=neffSite;j--;){
ans[j * lagj + i * lagi] = fmax2(sigma * gp[j] + ipoissonMinusHalfSigma2,
ans[j * lagj + i * lagi]);
nKO -= (thresh <= ans[j * lagj + i * lagi]);
}
}
}
PutRNGstate();
/* So fare we generate a max-stable process with standard Gumbel
margins. Switch to unit Frechet ones */
for (i=*nObs * neffSite;i--;)
ans[i] = exp(ans[i]);
free(covmat); free(gp);
return;
}
void rgeomcirc(int *nObs, int *ngrid, double *steps, int *dim,
int *covmod, double *sigma2, double *nugget, double *range,
double *smooth, double *uBound, double *ans){
/* This function generates random fields from the geometric model
nObs: the number of observations to be generated
ngrid: the number of locations along one axis
dim: the random field is generated in R^dim
covmod: the covariance model
nugget: the nugget parameter
range: the range parameter
smooth: the smooth parameter
uBound: the uniform upper bound for the stoch. proc.
ans: the generated random field */
int i, j, k = -1, nbar = R_pow_di(*ngrid, *dim), r, m;
const double loguBound = log(*uBound), halfSigma2 = 0.5 * *sigma2,
zero = 0;
double sigma = sqrt(*sigma2), sill = 1 - *nugget, *rho, *irho, *dist;
//Below is a table of highly composite numbers
int HCN[39] = {1, 2, 4, 6, 12, 24, 36, 48, 60, 120, 180, 240,
360, 720, 840, 1260, 1680, 2520, 5040, 7560,
10080, 15120, 20160, 25200, 27720, 45360, 50400,
55440, 83160, 110880, 166320, 221760, 277200,
332640, 498960, 554400, 665280, 720720, 1081080};
/* Find the smallest size m for the circulant embedding matrix */
{
int dummy = 2 * (*ngrid - 1);
do {
k++;
m = HCN[k];
} while (m < dummy);
}
/* ---------- beginning of the embedding stage ---------- */
int mbar = m * m, halfM = m / 2, notPosDef = 0;
do {
dist = (double *)R_alloc(mbar, sizeof(double));
notPosDef = 0;
//Computation of the distance
for (r=mbar;r--;){
i = r % m;
j = r / m;
if (i > halfM)
i -= m;
if (j > halfM)
j -= m;
dist[r] = hypot(steps[0] * i, steps[1] * j);
}
//Computations of the covariances
rho = (double *)R_alloc(mbar, sizeof(double));
irho = (double *)R_alloc(mbar, sizeof(double));
for (i=mbar;i--;)
irho[i] = 0;
switch (*covmod){
case 1:
whittleMatern(dist, mbar, zero, sill, *range, *smooth, rho);
break;
case 2:
cauchy(dist, mbar, zero, sill, *range, *smooth, rho);
break;
case 3:
powerExp(dist, mbar, zero, sill, *range, *smooth, rho);
break;
case 4:
bessel(dist, mbar, *dim, zero, sill, *range, *smooth, rho);
break;
}
/* Compute the eigen values to check if the circulant embbeding
matrix is positive definite */
/* Note : The next lines is only valid for 2d random fields. I
need to change if there are m_1 \neq m_2 as I suppose that m_1
= m_2 = m */
int maxf, maxp;
fft_factor(m, &maxf, &maxp);
double *work = (double *)R_alloc(4 * maxf, sizeof(double));
int *iwork = (int *)R_alloc(maxp, sizeof(int));
fft_work(rho, irho, m, m, 1, -1, work, iwork);
fft_factor(m, &maxf, &maxp);
work = (double *)R_alloc(4 * maxf, sizeof(double));
iwork = (int *)R_alloc(maxp, sizeof(int));
fft_work(rho, irho, 1, m, m, -1, work, iwork);
//Check if the eigenvalues are all positive
for (i=mbar;i--;){
notPosDef |= (rho[i] <= 0) || (fabs(irho[i]) > 0.001);
}
if (notPosDef){
k++;
m = HCN[k];
halfM = m / 2;
mbar = m * m;
}
if (k > 30)
error("Impossible to embbed the covariance matrix");
} while (notPosDef);
/* --------- end of the embedding stage --------- */
/* Computation of the square root of the eigenvalues */
for (i=mbar;i--;){
rho[i] = sqrt(rho[i]);
irho[i] = 0;//No imaginary part
}
int mdag = m / 2 + 1, mdagbar = mdag * mdag;
double isqrtMbar = 1 / sqrt(mbar);
double *a = (double *)R_alloc(mbar, sizeof(double));
double *ia = (double *)R_alloc(mbar, sizeof(double));
GetRNGstate();
for (i=*nObs;i--;){
int nKO = nbar;
double poisson = 0;
while (nKO) {
/* The stopping rule is reached when nKO = 0 i.e. when each site
satisfies the condition in Eq. (8) of Schlather (2002) */
int j;
double *gp = (double *)R_alloc(nbar, sizeof(double));
poisson += exp_rand();
double ipoisson = -log(poisson), thresh = loguBound + ipoisson;
/* We simulate one realisation of a gaussian random field with
the required covariance function */
circcore(rho, a, ia, m, halfM, mdag, mdagbar, *ngrid, nbar, isqrtMbar, *nugget, gp);
nKO = nbar;
double ipoissonMinusHalfSigma2 = ipoisson - halfSigma2;
for (j=nbar;j--;){
ans[j + i * nbar] = fmax2(sigma * gp[j] + ipoissonMinusHalfSigma2,
ans[j + i * nbar]);
nKO -= (thresh <= ans[j + i * nbar]);
}
}
}
PutRNGstate();
/* So fare we generate a max-stable process with standard Gumbel
margins. Switch to unit Frechet ones */
for (i=*nObs * nbar;i--;)
ans[i] = exp(ans[i]);
return;
}
// [[Rcpp::register]]
unsigned long exitRNGScope() {
RNGScopeCounter--;
if (RNGScopeCounter == 0) PutRNGstate();
return RNGScopeCounter ;
}
void count_permus_with_at_least_k_unfixed_points ( int*n, int *k, double * res){
GetRNGstate();
Generic gen;
*res = (double)gen.count_permus_with_at_least_k_unfixed_points(*n, *k);
PutRNGstate();
}
//extern "C"{
SEXP sampler(
/*prior params*/
double *a1, double *a2, /* prior for tau2*/
double *b1, double *b2, /* prior for sigma2 */
double *alphaW, double *betaW, /* prior for w */
double *v0, /* gamma */
double *varKsi, /*vector length qKsiUpdate!!*/
/*model dimensions*/
int *q, /*length of ksi*/
int *qKsiUpdate, /*length of updated ksi*/
int *p, /*length alpha*/
int *pPen, /*length penalized alpha/ tau2 / gamma*/
int *n, /* no. of obs.*/
int *d, /*vector (length p): group sizes*/
/*parameter vectors*/
double *beta,
double *alpha,
double *ksi,
double *tau2,
double *gamma,
double *sigma2,
double *w,
/* (precomputed) constants */
double *y,
double *X,
double *G,
double *scale,
double *offset,
/*info about updateBlocks*/
int *blocksAlpha,
int *indA1Alpha,
int *indA2Alpha,
int *blocksKsi,
int *indA1Ksi,
int *indA2Ksi,
/*MCMC parameters*/
int *pcts,
int *burnin,
int *thin,
int *totalLength,
int *verbose,
double *ksiDF,
int *scaleMode,
double *modeSwitching,
int *family,
double *acceptKsi,
double *acceptAlpha,
/*return matrices*/
double *betaMatR,
double *alphaMatR,
double *ksiMatR,
double *gammaMatR,
double *probV1MatR,
double *tau2MatR,
double *sigma2MatR,
double *wMatR,
double *likMatR,
double *logPostMatR
)
{
// ############################################### //
// ######## unwrap/initialize args ############### //
// ############################################### //
int pIncluded=0, i=0, j=0, startPen = *p-*pPen, qKsiNoUpdate = *q - *qKsiUpdate,
save = 0, keep = *burnin, nrv =1, info=0,
nSamp=(*totalLength-*burnin)/(*thin), oneInt = 1, zeroInt = 0;
double *p1 =Calloc(*pPen, double);
double infV = 100000, oneV = 1.0, zeroV = 0.0, minusOneV =-1.0;
double *one=&oneV, *zero=&zeroV, *minusOne=&minusOneV, *inf=&infV, acceptance=0;
double invSigma2 = 1 / *sigma2, sqrtInvSigma2 = R_pow(invSigma2, 0.5);
double *penAlphaSq, *alphaLong, *varAlpha, *priorMeanAlpha, *modeAlpha, *offsetAlpha;;
penAlphaSq = Calloc(*pPen, double);
for(int i=*p-*pPen; i<*p; i++) penAlphaSq[i- *p + *pPen] = R_pow(alpha[i], 2.0);
alphaLong = Calloc(*q, double);
F77_CALL(dgemm)("N","N", q, &oneInt, p, one, G, q, alpha, p, zero, alphaLong, q);
varAlpha = Calloc(*p, double);
for(int i=0; i<startPen; i++) varAlpha[i] = *inf; /*unpenalized*/
for(int i=startPen; i<*p; i++) varAlpha[i] = tau2[i-startPen]*gamma[i-startPen]; /*penalized*/
priorMeanAlpha = Calloc(*p, double);
setToZero(priorMeanAlpha, *p);
modeAlpha = Calloc(*p, double);
F77_CALL(dcopy)(p, alpha, &oneInt, modeAlpha, &oneInt);
offsetAlpha = Calloc(*n, double);
F77_CALL(dcopy)(n, offset, &oneInt, offsetAlpha, &oneInt);
double *ksiUpdate, *priorMeanKsi, *modeKsi, *offsetKsi;
int safeQKsiUpdate = imax2(1, *qKsiUpdate);
//ksiUpdate contains the last qKsiUpdate elements in ksi
ksiUpdate = Calloc(safeQKsiUpdate, double);
F77_CALL(dcopy)(&safeQKsiUpdate, &ksi[*q-safeQKsiUpdate], &oneInt, ksiUpdate, &oneInt);
priorMeanKsi = Calloc(safeQKsiUpdate, double);
setToZero(priorMeanKsi, safeQKsiUpdate);
for(int i=0; i<*qKsiUpdate; i++) priorMeanKsi[i] = 1.0;
modeKsi = Calloc(safeQKsiUpdate, double);
setToZero(modeKsi, safeQKsiUpdate);
for(int i=0; i<*qKsiUpdate; i++) modeKsi[i] = ksi[i+qKsiNoUpdate];
// offsetKsi = offset + X_d=1*alpha : use lin.predictor of grps with ksi==1 as offset
offsetKsi = Calloc(*n, double);
F77_CALL(dcopy)(n, offset, &oneInt, offsetKsi, &oneInt);
if(qKsiNoUpdate < *q){
if(qKsiNoUpdate > 0){
F77_CALL(dgemm)("N","N", n, &oneInt, &qKsiNoUpdate, one, X, n, alpha, &qKsiNoUpdate, one, offsetKsi, n);
}
}
double *eta, *resid, rss, *XAlpha, *XKsiUpdate, *etaOffset;
eta = Calloc(*n, double);
F77_CALL(dgemm)("N","N", n, &oneInt, q, one, X, n, beta, q, zero, eta, n);
resid = Calloc(*n, double);
rss = 0;
for(int i=0; i<*n; i++) {
resid[i] = y[i]-eta[i] - offset[i];
rss += R_pow(resid[i], 2.0);
}
XAlpha = Calloc(*p * (*n), double);
updateXAlpha(XAlpha, X, G, ksi, q, qKsiUpdate, p, n);
XKsiUpdate = Calloc( *n * safeQKsiUpdate, double);
setToZero(XKsiUpdate, *n * safeQKsiUpdate);
if(qKsiNoUpdate < *q){
updateXKsi(XKsiUpdate, X, alphaLong, q, &qKsiNoUpdate, n);
}
etaOffset = Calloc(*n, double);
for(int i=0; i<*n; i++) etaOffset[i] = eta[i]+offset[i];
// ############################################################ //
// ######## set up blocks for blockwise updates ############### //
// ############################################################ //
XBlockQR *AlphaBlocks = Calloc(*blocksAlpha, XBlockQR);
XBlockQR *KsiBlocks = Calloc(*blocksKsi, XBlockQR);
for(int i=0; i < *blocksAlpha; i++){
(AlphaBlocks[i]).indA1 = indA1Alpha[i];
(AlphaBlocks[i]).indA2 = indA2Alpha[i];
(AlphaBlocks[i]).qA = (AlphaBlocks[i]).indA2 - (AlphaBlocks[i]).indA1 + 1;
(AlphaBlocks[i]).qI = *p - (AlphaBlocks[i]).qA;
(AlphaBlocks[i]).qraux = Calloc((AlphaBlocks[i]).qA, double);
setToZero((AlphaBlocks[i]).qraux, (AlphaBlocks[i]).qA);
(AlphaBlocks[i]).work = Calloc((AlphaBlocks[i]).qA, double);
setToZero((AlphaBlocks[i]).work, (AlphaBlocks[i]).qA);
(AlphaBlocks[i]).pivots = Calloc((AlphaBlocks[i]).qA, int);
for(int j=0; j < (AlphaBlocks[i]).qA; j++) (AlphaBlocks[i]).pivots[j] = 0;
(AlphaBlocks[i]).coefI = Calloc((AlphaBlocks[i]).qI, double);
setToZero((AlphaBlocks[i]).coefI, (AlphaBlocks[i]).qI);
(AlphaBlocks[i]).Xa = Calloc(((AlphaBlocks[i]).qA + *n) * (AlphaBlocks[i]).qA, double);
setToZero((AlphaBlocks[i]).Xa, ((AlphaBlocks[i]).qA + *n) * (AlphaBlocks[i]).qA);
(AlphaBlocks[i]).Xi = Calloc(*n * (AlphaBlocks[i]).qI, double);
setToZero((AlphaBlocks[i]).Xi, *n * (AlphaBlocks[i]).qI );
(AlphaBlocks[i]).ya = Calloc(((AlphaBlocks[i]).qA + *n), double);
F77_CALL(dcopy)(n, y, &nrv, (AlphaBlocks[i]).ya, &nrv);
setToZero((AlphaBlocks[i]).ya + *n, (AlphaBlocks[i]).qA);
(AlphaBlocks[i]).m = Calloc((AlphaBlocks[i]).qA, double);
setToZero((AlphaBlocks[i]).m, (AlphaBlocks[i]).qA);
(AlphaBlocks[i]).err = Calloc((AlphaBlocks[i]).qA, double);
setToZero((AlphaBlocks[i]).err, (AlphaBlocks[i]).qA);
}
initializeBlocksQR(AlphaBlocks, XAlpha, *n, *blocksAlpha, *p, varAlpha, scale);
if(*qKsiUpdate > 0){
for(int i=0; i < *blocksKsi; i++){
(KsiBlocks[i]).indA1 = indA1Ksi[i];
(KsiBlocks[i]).indA2 = indA2Ksi[i];
(KsiBlocks[i]).qA = (KsiBlocks[i]).indA2 - (KsiBlocks[i]).indA1 + 1;
(KsiBlocks[i]).qI = *qKsiUpdate - (KsiBlocks[i]).qA;
(KsiBlocks[i]).qraux = Calloc((KsiBlocks[i]).qA, double);
setToZero((KsiBlocks[i]).qraux, (KsiBlocks[i]).qA);
(KsiBlocks[i]).work = Calloc((KsiBlocks[i]).qA, double);
setToZero((KsiBlocks[i]).work, (KsiBlocks[i]).qA);
(KsiBlocks[i]).pivots = Calloc((KsiBlocks[i]).qA, int);
for(int j=0; j < (KsiBlocks[i]).qA; j++) (KsiBlocks[i]).pivots[j] = 0;
(KsiBlocks[i]).coefI = Calloc((KsiBlocks[i]).qI, double);
setToZero((KsiBlocks[i]).coefI, (KsiBlocks[i]).qI);
(KsiBlocks[i]).Xa = Calloc(((KsiBlocks[i]).qA + *n) * (KsiBlocks[i]).qA, double);
setToZero((KsiBlocks[i]).Xa, ((KsiBlocks[i]).qA + *n) * (KsiBlocks[i]).qA);
(KsiBlocks[i]).Xi = Calloc(*n * (KsiBlocks[i]).qI, double);
setToZero((KsiBlocks[i]).Xi, *n * (KsiBlocks[i]).qI );
(KsiBlocks[i]).ya = Calloc(((KsiBlocks[i]).qA + *n), double);
F77_CALL(dcopy)(n, y, &nrv, (KsiBlocks[i]).ya, &nrv);
setToZero((KsiBlocks[i]).ya + *n, (KsiBlocks[i]).qA);
(KsiBlocks[i]).m = Calloc((KsiBlocks[i]).qA, double);
setToZero((KsiBlocks[i]).m, (KsiBlocks[i]).qA);
(KsiBlocks[i]).err = Calloc((KsiBlocks[i]).qA, double);
setToZero((KsiBlocks[i]).err, (KsiBlocks[i]).qA);
}
initializeBlocksQR(KsiBlocks, XKsiUpdate, *n, *blocksKsi, *qKsiUpdate, varKsi, scale);
}
// ############################################### //
// ######## start sampling ############### //
// ############################################### //
#ifdef Win32
R_FlushConsole();
#endif
/* sampling */
GetRNGstate();
for(i = 0; i < *totalLength; i++)
{
debugMsg("\n###########################################\n\n");
//update alpha
{
//update varAlpha
for(j=startPen; j<*p; j++) varAlpha[j] = tau2[j-startPen] * gamma[j-startPen];
//update alpha
updateCoefQR(y, XAlpha, AlphaBlocks,
*blocksAlpha,
alpha,
varAlpha, *p,
scale,
*n, nrv, oneInt, info, *minusOne, *zero, *one, 1, priorMeanAlpha,
*family, modeAlpha, eta, acceptAlpha, offsetAlpha, *modeSwitching, zeroInt);
}
//update ksi
if(qKsiNoUpdate < *q){
//update alphaLong = G %*% alpha
F77_CALL(dgemm)("N","N", q, &oneInt, p, one, G, q, alpha, p, zero, alphaLong, q);
//update design for ksi
updateXKsi(XKsiUpdate, X, alphaLong, q, &qKsiNoUpdate, n);
//update offsetKsi
if(qKsiNoUpdate > 0){
F77_CALL(dcopy)(n, offset, &oneInt, offsetKsi, &oneInt);
F77_CALL(dgemm)("N","N", n, &oneInt, &qKsiNoUpdate, one, X, n, alpha, &qKsiNoUpdate, one, offsetKsi, n);
}
for(j = 0; j < *qKsiUpdate; j++){
priorMeanKsi[j] = sign( 1/(1 + exp(-2*ksiUpdate[j]/varKsi[j])) - runif(0,1) );
}
if(*ksiDF>0){
updateVarKsi(ksiUpdate, varKsi, ksiDF, priorMeanKsi, qKsiNoUpdate, *q);
}
updateCoefQR(y, XKsiUpdate, KsiBlocks,
*blocksKsi,
ksiUpdate, varKsi, *qKsiUpdate,
scale,
*n, nrv, oneInt, info, *minusOne, *zero, *one, 1, priorMeanKsi,
*family, modeKsi, eta, acceptKsi, offsetKsi, *modeSwitching, *scaleMode);
//write back to ksi
F77_CALL(dcopy)(qKsiUpdate, ksiUpdate, &oneInt, &ksi[*q-*qKsiUpdate], &oneInt);
//rescale ksi, alpha & put back in ksiUpdate
if(*scaleMode > 0){
rescaleKsiAlpha(ksi, alpha, varKsi, tau2, G, d, *p, *q, qKsiNoUpdate, *pPen, *scaleMode, modeAlpha, modeKsi, *family);
F77_CALL(dcopy)(qKsiUpdate, &ksi[*q-*qKsiUpdate], &oneInt, ksiUpdate, &oneInt);
}
//update XAlpha
updateXAlpha(XAlpha, X, G, ksi, q, qKsiUpdate, p, n);
//update alphaLong = G %*% alpha
F77_CALL(dgemm)("N","N", q, &oneInt, p, one, G, q, alpha, p, zero, alphaLong, q);
} else {
F77_CALL(dcopy)(q, alpha, &oneInt, alphaLong, &oneInt);
}
for(int i = *p-*pPen; i < *p; i++) penAlphaSq[i - *p + *pPen] = R_pow(alpha[i], 2.0);
updateTau(penAlphaSq, gamma, tau2, *a1, *a2, *pPen);
updateP1Gamma(penAlphaSq, tau2, p1, gamma, *v0, *w, *pPen);
pIncluded = 0;
for(j=0; j<*p - startPen; j++) pIncluded += (gamma[j] == 1.0);
*w = rbeta( *alphaW + pIncluded, *betaW + *p - pIncluded );
// update beta
for(j = 0; j < *q; j++){
beta[j] = alphaLong[j]*ksi[j];
}
//update eta, eta+offset
F77_CALL(dgemm)("N", "N", n, &oneInt, q, one, X, n, beta, q, zero, eta, n);
for(int i=0; i<*n; i++) etaOffset[i] = eta[i] + offset[i];
//update sigma_eps
if(*family == 0){
//resid = y - eta - offset
F77_CALL(dcopy)(n, y, &nrv, resid, &nrv); //resid <- y
F77_CALL(daxpy)(n, minusOne, etaOffset, &nrv, resid, &nrv); //resid <- resid - eta - offset
//rss = resid'resid
rss = F77_CALL(ddot)(n, resid, &oneInt, resid, &oneInt);
//update sigma2
invSigma2 = rgamma(*n/2 + *b1, 1/(rss/2 + *b2));
sqrtInvSigma2 = R_pow(invSigma2, 0.5);
scale[0] = sqrtInvSigma2;
*sigma2 = 1 / invSigma2;
}
if(i >= *burnin){
/* report progress */
if(*verbose){
for(j=0; j<9; j++){
if(i == pcts[j]){
Rprintf(".");
#ifdef Win32
R_FlushConsole();
#endif
break;
}
}
}
/* save samples*/
if(i == keep){
for(j = 0; j < *q; j++){
(betaMatR)[save + j*nSamp] = beta[j];
(ksiMatR)[save + j*nSamp] = ksi[j];
}
for(j=0; j < *p; j++){
(alphaMatR)[save + j*nSamp] = alpha[j];
}
for(j=0; j < *pPen; j++){
(tau2MatR)[save + j*nSamp] = tau2[j];
(gammaMatR)[save + j*nSamp] = gamma[j];
(probV1MatR)[save + j*nSamp] = p1[j];
}
(wMatR)[save] = *w;
(sigma2MatR)[save] = *sigma2;
likMatR[save] = logLik(y, etaOffset, *family, scale, *n);
(logPostMatR)[save] = updateLogPost(y, alpha, varAlpha,
ksi, varKsi, scale, *b1, *b2, gamma, *w, *alphaW, *betaW,
tau2, *a1, *a2, *n, *q, *p, *pPen, pIncluded, qKsiNoUpdate, priorMeanKsi, *family, likMatR[save]);
keep = keep + *thin;
save ++;
R_CheckUserInterrupt();
}
} else {
if(*verbose){
if(i == (*burnin-1)){
Rprintf("b");
#ifdef Win32
R_FlushConsole();
#endif
}
}
}
} /* end for i*/
PutRNGstate();
if(*verbose) Rprintf(".");
if(*family > 0) {
acceptance = 0.0;
for(j=0; j<*blocksAlpha; j++) acceptance += acceptAlpha[j];
acceptance = 0.0;
if(qKsiNoUpdate < *q){
for(j=0; j<*blocksKsi; j++) acceptance += acceptKsi[j];
}
}
Free(etaOffset); Free(XKsiUpdate); Free(XAlpha); Free(resid); Free(eta);
Free(offsetKsi); Free(modeKsi); Free(priorMeanKsi); Free(ksiUpdate);
Free(offsetAlpha);
Free(modeAlpha);
Free(priorMeanAlpha);
Free(varAlpha);
Free(alphaLong);
Free(penAlphaSq);
freeXBlockQR(AlphaBlocks, *blocksAlpha);
if(qKsiNoUpdate < *q) freeXBlockQR(KsiBlocks, *blocksKsi);
Free(p1);
return(R_NilValue);
}/* end sampler ()*/
void BweibCorSurvmcmc(double survData[],
int *n,
int *p,
int *J,
double nj[],
double hyperParams[],
double mcmcParams[],
double startValues[],
int *numReps,
int *thin,
double *burninPerc,
double samples_beta[],
double samples_alpha[],
double samples_kappa[],
double samples_V[],
double samples_zeta[],
double samples_misc[],
double moveVec[])
{
GetRNGstate();
time_t now;
int i, j, MM;
/* Survival Data */
gsl_vector *survTime = gsl_vector_alloc(*n);
gsl_vector *survEvent = gsl_vector_alloc(*n);
gsl_vector *cluster = gsl_vector_alloc(*n);
for(i = 0; i < *n; i++)
{
gsl_vector_set(survTime, i, survData[(0 * *n) + i]);
gsl_vector_set(survEvent, i, survData[(1* *n) + i]);
gsl_vector_set(cluster, i, survData[(2* *n) + i]);
}
int nP;
if(*p > 0) nP = *p;
if(*p == 0) nP = 1;
gsl_matrix *survCov = gsl_matrix_calloc(*n, nP);
if(*p >0)
{
for(i = 0; i < *n; i++)
{
for(j = 0; j < *(p); j++)
{
gsl_matrix_set(survCov, i, j, survData[((3+j)* *n) + i]);
}
}
}
gsl_vector *n_j = gsl_vector_calloc(*J);
for(j = 0; j < *J; j++)
{
gsl_vector_set(n_j, j, nj[j]);
}
/* Hyperparameters */
double a = hyperParams[0];
double b = hyperParams[1];
double c = hyperParams[2];
double d = hyperParams[3];
double rho1 = hyperParams[4];
double rho2 = hyperParams[5];
/* varialbes for M-H step */
double mhProp_alpha_var = mcmcParams[0];
double mhProp_V_var = mcmcParams[1];
/* Starting values */
gsl_vector *beta = gsl_vector_calloc(nP);
if(*p > 0)
{
for(j = 0; j < *p; j++) gsl_vector_set(beta, j, startValues[j]);
}
double alpha = startValues[*p];
double kappa = startValues[*p + 1];
gsl_vector *V = gsl_vector_calloc(*J);
for(j = 0; j < *J; j++)
{
gsl_vector_set(V, j, startValues[*p + 2 + j]);
}
double zeta = startValues[*p + 2 + *J];
/* Variables required for storage of samples */
int StoreInx;
gsl_vector *accept_beta = gsl_vector_calloc(nP);
gsl_vector *accept_V = gsl_vector_calloc(*J);
int accept_alpha = 0;
/* Compute probabilities for various types of moves */
double pRP, pSH, pSC, pCP, pVP, choice;
int move, numUpdate;
numUpdate = 4;
if(*p > 0) numUpdate += 1;
pSH = (double) 0.3;
pCP = (double) 0.3;
double probSub = (1 - pSH - pCP)/(numUpdate-2);
pRP = (*p > 0) ? probSub : 0;
pSC = probSub;
pVP = 1-(pRP + pSH + pSC + pCP);
for(MM = 0; MM < *numReps; MM++)
{
/* selecting a move */
/* move: 1=RP, 2=SH, 3=SC, 4=CP, 5=VP*/
choice = runif(0, 1);
move = 1;
if(choice > pRP) move = 2;
if(choice > pRP + pSH) move = 3;
if(choice > pRP + pSH + pSC) move = 4;
if(choice > pRP + pSH + pSC + pCP) move = 5;
moveVec[MM] = (double) move;
/* updating regression parameter: beta
move = 100;*/
if(move == 1)
{
BweibCorSurv_updateRP(beta, &alpha, &kappa, V, survTime, survEvent, cluster, survCov, accept_beta);
}
/* updating shape parameter: alpha
move = 40; */
if(move == 2)
{
BweibSurv_updateSH_rw2(beta, &alpha, &kappa, V, survTime, survEvent, cluster, survCov, mhProp_alpha_var, a, b, &accept_alpha);
}
/* updating scale parameter: kappa
move = 70; */
if(move == 3)
{
BweibSurv_updateSC(beta, &alpha, &kappa, V, survTime, survEvent, cluster, survCov, c, d);
}
/* updating cluster-specific random effect: V
move = 130;*/
if(move == 4)
{
BweibSurv_updateCP(beta, alpha, kappa, V, zeta, survTime, survEvent, cluster, survCov, n_j, accept_V, mhProp_V_var);
}
/* updating precition parameter of the random effect distribution: zeta
move = 160;*/
if(move == 5)
{
BweibSurv_updateVP(V, &zeta, rho1, rho2);
}
/* */
/* Storing posterior samples */
if( ( (MM+1) % *thin ) == 0 && (MM+1) > (*numReps * *burninPerc))
{
StoreInx = (MM+1)/(*thin)- (*numReps * *burninPerc)/(*thin);
samples_alpha[StoreInx - 1] = alpha;
samples_kappa[StoreInx - 1] = kappa;
if(*p >0)
{
for(j = 0; j < *p; j++) samples_beta[(StoreInx - 1) * (*p) + j] = gsl_vector_get(beta, j);
}
for(j = 0; j < *J; j++) samples_V[(StoreInx - 1) * (*J) + j] = gsl_vector_get(V, j);
samples_zeta[StoreInx - 1] = zeta;
if(MM == (*numReps - 1))
{
/* */
if(*p >0)
{
for(j = 0; j < *p; j++) samples_misc[j] = (int) gsl_vector_get(accept_beta, j);
}
/* */
samples_misc[*p] = accept_alpha;
/* */
for(i = 0; i < *J; i++) samples_misc[*p + 1 + i] = (int) gsl_vector_get(accept_V, i);
}
}
if( ( (MM+1) % 10000 ) == 0)
{
time(&now);
Rprintf("iteration: %d: %s\n", MM+1, ctime(&now));
R_FlushConsole();
R_ProcessEvents();
}
}
PutRNGstate();
return;
}
SEXP euler_model_simulator (SEXP func,
SEXP xstart, SEXP times, SEXP params,
SEXP deltat, SEXP method, SEXP zeronames,
SEXP tcovar, SEXP covar, SEXP args, SEXP gnsi)
{
int nprotect = 0;
pompfunmode mode = undef;
int nvars, npars, nreps, ntimes, nzeros, ncovars, covlen;
int nstep = 0;
double dt, dtt;
SEXP X;
SEXP ans, nm, fn, fcall = R_NilValue, rho = R_NilValue;
SEXP Snames, Pnames, Cnames;
SEXP cvec, tvec = R_NilValue;
SEXP xvec = R_NilValue, pvec = R_NilValue, dtvec = R_NilValue;
int *pidx = 0, *sidx = 0, *cidx = 0, *zidx = 0;
pomp_onestep_sim *ff = NULL;
int meth = INTEGER_VALUE(method);
// meth: 0 = Euler, 1 = one-step, 2 = fixed step
dtt = NUMERIC_VALUE(deltat);
if (dtt <= 0)
errorcall(R_NilValue,"'delta.t' should be a positive number");
{
int *dim;
dim = INTEGER(GET_DIM(xstart)); nvars = dim[0]; nreps = dim[1];
dim = INTEGER(GET_DIM(params)); npars = dim[0];
dim = INTEGER(GET_DIM(covar)); covlen = dim[0]; ncovars = dim[1];
ntimes = LENGTH(times);
}
PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(xstart))); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(covar))); nprotect++;
// set up the covariate table
struct lookup_table covariate_table = {covlen, ncovars, 0, REAL(tcovar), REAL(covar)};
// vector for interpolated covariates
PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++;
SET_NAMES(cvec,Cnames);
// indices of accumulator variables
nzeros = LENGTH(zeronames);
zidx = INTEGER(PROTECT(matchnames(Snames,zeronames,"state variables"))); nprotect++;
// extract user function
PROTECT(fn = pomp_fun_handler(func,gnsi,&mode)); nprotect++;
// set up
switch (mode) {
case Rfun: // R function
PROTECT(dtvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(tvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++;
PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
SET_NAMES(xvec,Snames);
SET_NAMES(pvec,Pnames);
// set up the function call
PROTECT(fcall = LCONS(cvec,args)); nprotect++;
SET_TAG(fcall,install("covars"));
PROTECT(fcall = LCONS(dtvec,fcall)); nprotect++;
SET_TAG(fcall,install("delta.t"));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(tvec,fcall)); nprotect++;
SET_TAG(fcall,install("t"));
PROTECT(fcall = LCONS(xvec,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// get function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
break;
case native: // native code
// construct state, parameter, covariate indices
sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++;
pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++;
cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++;
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
break;
default:
errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov
break;
}
// create array to hold results
{
int dim[3] = {nvars, nreps, ntimes};
PROTECT(X = makearray(3,dim)); nprotect++;
setrownames(X,Snames,3);
}
// copy the start values into the result array
memcpy(REAL(X),REAL(xstart),nvars*nreps*sizeof(double));
if (mode==1) {
set_pomp_userdata(args);
GetRNGstate();
}
// now do computations
{
int first = 1;
int use_names = 0;
int *posn = 0;
double *time = REAL(times);
double *xs = REAL(X);
double *xt = REAL(X)+nvars*nreps;
double *cp = REAL(cvec);
double *ps = REAL(params);
double t = time[0];
double *pm, *xm;
int i, j, k, step;
for (step = 1; step < ntimes; step++, xs = xt, xt += nvars*nreps) {
R_CheckUserInterrupt();
if (t > time[step]) {
errorcall(R_NilValue,"'times' is not an increasing sequence");
}
memcpy(xt,xs,nreps*nvars*sizeof(double));
// set accumulator variables to zero
for (j = 0; j < nreps; j++)
for (i = 0; i < nzeros; i++)
xt[zidx[i]+nvars*j] = 0.0;
switch (meth) {
case 0: // Euler method
dt = dtt;
nstep = num_euler_steps(t,time[step],&dt);
break;
case 1: // one step
dt = time[step]-t;
nstep = (dt > 0) ? 1 : 0;
break;
case 2: // fixed step
dt = dtt;
nstep = num_map_steps(t,time[step],dt);
break;
default:
errorcall(R_NilValue,"unrecognized 'method'"); // # nocov
break;
}
for (k = 0; k < nstep; k++) { // loop over Euler steps
// interpolate the covar functions for the covariates
table_lookup(&covariate_table,t,cp);
for (j = 0, pm = ps, xm = xt; j < nreps; j++, pm += npars, xm += nvars) { // loop over replicates
switch (mode) {
case Rfun: // R function
{
double *xp = REAL(xvec);
double *pp = REAL(pvec);
double *tp = REAL(tvec);
double *dtp = REAL(dtvec);
double *ap;
*tp = t;
*dtp = dt;
memcpy(xp,xm,nvars*sizeof(double));
memcpy(pp,pm,npars*sizeof(double));
if (first) {
PROTECT(ans = eval(fcall,rho)); nprotect++; // evaluate the call
if (LENGTH(ans) != nvars) {
errorcall(R_NilValue,"user 'step.fun' returns a vector of %d state variables but %d are expected: compare initial conditions?",
LENGTH(ans),nvars);
}
PROTECT(nm = GET_NAMES(ans)); nprotect++;
use_names = !isNull(nm);
if (use_names) {
posn = INTEGER(PROTECT(matchnames(Snames,nm,"state variables"))); nprotect++;
}
ap = REAL(AS_NUMERIC(ans));
first = 0;
} else {
ap = REAL(AS_NUMERIC(eval(fcall,rho)));
}
if (use_names) {
for (i = 0; i < nvars; i++) xm[posn[i]] = ap[i];
} else {
for (i = 0; i < nvars; i++) xm[i] = ap[i];
}
}
break;
case native: // native code
(*ff)(xm,pm,sidx,pidx,cidx,ncovars,cp,t,dt);
break;
default:
errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov
break;
}
}
t += dt;
if ((meth == 0) && (k == nstep-2)) { // penultimate step
dt = time[step]-t;
t = time[step]-dt;
}
}
}
}
if (mode==1) {
PutRNGstate();
unset_pomp_userdata();
}
UNPROTECT(nprotect);
return X;
}
void classRF(double *x, int *dimx, int *cl, int *ncl, int *cat, int *maxcat,
int *sampsize, int *strata, int *Options, int *ntree, int *nvar,
int *ipi, double *classwt, double *cut, int *nodesize,
int *outcl, int *counttr, double *prox,
double *imprt, double *impsd, double *impmat, int *nrnodes,
int *ndbigtree, int *nodestatus, int *bestvar, int *treemap,
int *nodeclass, double *xbestsplit, double *errtr,
int *testdat, double *xts, int *clts, int *nts, double *countts,
int *outclts, int labelts, double *proxts, double *errts,
int *inbag) {
/******************************************************************
* C wrapper for random forests: get input from R and drive
* the Fortran routines.
*
* Input:
*
* x: matrix of predictors (transposed!)
* dimx: two integers: number of variables and number of cases
* cl: class labels of the data
* ncl: number of classes in the responsema
* cat: integer vector of number of classes in the predictor;
* 1=continuous
* maxcat: maximum of cat
* Options: 7 integers: (0=no, 1=yes)
* add a second class (for unsupervised RF)?
* 1: sampling from product of marginals
* 2: sampling from product of uniforms
* assess variable importance?
* calculate proximity?
* calculate proximity based on OOB predictions?
* calculate outlying measure?
* how often to print output?
* keep the forest for future prediction?
* ntree: number of trees
* nvar: number of predictors to use for each split
* ipi: 0=use class proportion as prob.; 1=use supplied priors
* pi: double vector of class priors
* nodesize: minimum node size: no node with fewer than ndsize
* cases will be split
*
* Output:
*
* outcl: class predicted by RF
* counttr: matrix of votes (transposed!)
* imprt: matrix of variable importance measures
* impmat: matrix of local variable importance measures
* prox: matrix of proximity (if iprox=1)
******************************************************************/
int nsample0, mdim, nclass, addClass, mtry, ntest, nsample, ndsize,
mimp, nimp, near, nuse, noutall, nrightall, nrightimpall,
keepInbag, nstrata;
int jb, j, n, m, k, idxByNnode, idxByNsample, imp, localImp, iprox,
oobprox, keepf, replace, stratify, trace, *nright,
*nrightimp, *nout, *nclts, Ntree;
int *out, *bestsplitnext, *bestsplit, *nodepop, *jin, *nodex,
*nodexts, *nodestart, *ta, *ncase, *jerr, *varUsed,
*jtr, *classFreq, *idmove, *jvr,
*at, *a, *b, *mind, *nind, *jts, *oobpair;
int **strata_idx, *strata_size, last, ktmp, anyEmpty, ntry;
double av=0.0;
double *tgini, *tx, *wl, *classpop, *tclasscat, *tclasspop, *win,
*tp, *wr;
//Do initialization for COKUS's Random generator
seedMT(17); //works well with odd number so why don't use that
addClass = Options[0];
imp = Options[1];
localImp = Options[2];
iprox = Options[3];
oobprox = Options[4];
trace = Options[5];
keepf = Options[6];
replace = Options[7];
stratify = Options[8];
keepInbag = Options[9];
mdim = dimx[0];
nsample0 = dimx[1];
nclass = (*ncl==1) ? 2 : *ncl;
ndsize = *nodesize;
Ntree = *ntree;
mtry = *nvar;
ntest = *nts;
nsample = addClass ? (nsample0 + nsample0) : nsample0;
mimp = imp ? mdim : 1;
nimp = imp ? nsample : 1;
near = iprox ? nsample0 : 1;
if (trace == 0) trace = Ntree + 1;
/*printf("\nmdim %d, nclass %d, nrnodes %d, nsample %d, ntest %d\n", mdim, nclass, *nrnodes, nsample, ntest);
printf("\noobprox %d, mdim %d, nsample0 %d, Ntree %d, mtry %d, mimp %d", oobprox, mdim, nsample0, Ntree, mtry, mimp);
printf("\nstratify %d, replace %d",stratify,replace);
printf("\n");*/
tgini = (double *) S_alloc_alt(mdim, sizeof(double));
wl = (double *) S_alloc_alt(nclass, sizeof(double));
wr = (double *) S_alloc_alt(nclass, sizeof(double));
classpop = (double *) S_alloc_alt(nclass* *nrnodes, sizeof(double));
tclasscat = (double *) S_alloc_alt(nclass*32, sizeof(double));
tclasspop = (double *) S_alloc_alt(nclass, sizeof(double));
tx = (double *) S_alloc_alt(nsample, sizeof(double));
win = (double *) S_alloc_alt(nsample, sizeof(double));
tp = (double *) S_alloc_alt(nsample, sizeof(double));
out = (int *) S_alloc_alt(nsample, sizeof(int));
bestsplitnext = (int *) S_alloc_alt(*nrnodes, sizeof(int));
bestsplit = (int *) S_alloc_alt(*nrnodes, sizeof(int));
nodepop = (int *) S_alloc_alt(*nrnodes, sizeof(int));
nodestart = (int *) S_alloc_alt(*nrnodes, sizeof(int));
jin = (int *) S_alloc_alt(nsample, sizeof(int));
nodex = (int *) S_alloc_alt(nsample, sizeof(int));
nodexts = (int *) S_alloc_alt(ntest, sizeof(int));
ta = (int *) S_alloc_alt(nsample, sizeof(int));
ncase = (int *) S_alloc_alt(nsample, sizeof(int));
jerr = (int *) S_alloc_alt(nsample, sizeof(int));
varUsed = (int *) S_alloc_alt(mdim, sizeof(int));
jtr = (int *) S_alloc_alt(nsample, sizeof(int));
jvr = (int *) S_alloc_alt(nsample, sizeof(int));
classFreq = (int *) S_alloc_alt(nclass, sizeof(int));
jts = (int *) S_alloc_alt(ntest, sizeof(int));
idmove = (int *) S_alloc_alt(nsample, sizeof(int));
at = (int *) S_alloc_alt(mdim*nsample, sizeof(int));
a = (int *) S_alloc_alt(mdim*nsample, sizeof(int));
b = (int *) S_alloc_alt(mdim*nsample, sizeof(int));
mind = (int *) S_alloc_alt(mdim, sizeof(int));
nright = (int *) S_alloc_alt(nclass, sizeof(int));
nrightimp = (int *) S_alloc_alt(nclass, sizeof(int));
nout = (int *) S_alloc_alt(nclass, sizeof(int));
if (oobprox) {
oobpair = (int *) S_alloc_alt(near*near, sizeof(int));
}
//printf("nsample=%d\n", nsample);
/* Count number of cases in each class. */
zeroInt(classFreq, nclass);
for (n = 0; n < nsample; ++n) classFreq[cl[n] - 1] ++;
/* Normalize class weights. */
//Rprintf("ipi %d ",*ipi);
//for(n=0;n<nclass;n++) Rprintf("%d: %d, %f,",n,classFreq[n],classwt[n]);
normClassWt(cl, nsample, nclass, *ipi, classwt, classFreq);
//for(n=0;n<nclass;n++) Rprintf("%d: %d, %f,",n,classFreq[n],classwt[n]);
if (stratify) {
/* Count number of strata and frequency of each stratum. */
nstrata = 0;
for (n = 0; n < nsample0; ++n)
if (strata[n] > nstrata) nstrata = strata[n];
/* Create the array of pointers, each pointing to a vector
* of indices of where data of each stratum is. */
strata_size = (int *) S_alloc_alt(nstrata, sizeof(int));
for (n = 0; n < nsample0; ++n) {
strata_size[strata[n] - 1] ++;
}
strata_idx = (int **) S_alloc_alt(nstrata, sizeof(int *));
for (n = 0; n < nstrata; ++n) {
strata_idx[n] = (int *) S_alloc_alt(strata_size[n], sizeof(int));
}
zeroInt(strata_size, nstrata);
for (n = 0; n < nsample0; ++n) {
strata_size[strata[n] - 1] ++;
strata_idx[strata[n] - 1][strata_size[strata[n] - 1] - 1] = n;
}
} else {
nind = replace ? NULL : (int *) S_alloc_alt(nsample, sizeof(int));
}
/* INITIALIZE FOR RUN */
if (*testdat) zeroDouble(countts, ntest * nclass);
zeroInt(counttr, nclass * nsample);
zeroInt(out, nsample);
zeroDouble(tgini, mdim);
zeroDouble(errtr, (nclass + 1) * Ntree);
if (labelts) {
nclts = (int *) S_alloc_alt(nclass, sizeof(int));
for (n = 0; n < ntest; ++n) nclts[clts[n]-1]++;
zeroDouble(errts, (nclass + 1) * Ntree);
}
//printf("labelts %d\n",labelts);fflush(stdout);
if (imp) {
zeroDouble(imprt, (nclass+2) * mdim);
zeroDouble(impsd, (nclass+1) * mdim);
if (localImp) zeroDouble(impmat, nsample * mdim);
}
if (iprox) {
zeroDouble(prox, nsample0 * nsample0);
if (*testdat) zeroDouble(proxts, ntest * (ntest + nsample0));
}
makeA(x, mdim, nsample, cat, at, b);
//R_CheckUserInterrupt();
/* Starting the main loop over number of trees. */
GetRNGstate();
if (trace <= Ntree) {
/* Print header for running output. */
Rprintf("ntree OOB");
for (n = 1; n <= nclass; ++n) Rprintf("%7i", n);
if (labelts) {
Rprintf("| Test");
for (n = 1; n <= nclass; ++n) Rprintf("%7i", n);
}
Rprintf("\n");
}
idxByNnode = 0;
idxByNsample = 0;
//Rprintf("addclass %d, ntree %d, cl[300]=%d", addClass,Ntree,cl[299]);
for(jb = 0; jb < Ntree; jb++) {
//Rprintf("addclass %d, ntree %d, cl[300]=%d", addClass,Ntree,cl[299]);
//printf("jb=%d,\n",jb);
/* Do we need to simulate data for the second class? */
if (addClass) createClass(x, nsample0, nsample, mdim);
do {
zeroInt(nodestatus + idxByNnode, *nrnodes);
zeroInt(treemap + 2*idxByNnode, 2 * *nrnodes);
zeroDouble(xbestsplit + idxByNnode, *nrnodes);
zeroInt(nodeclass + idxByNnode, *nrnodes);
zeroInt(varUsed, mdim);
/* TODO: Put all sampling code into a function. */
/* drawSample(sampsize, nsample, ); */
if (stratify) { /* stratified sampling */
zeroInt(jin, nsample);
zeroDouble(tclasspop, nclass);
zeroDouble(win, nsample);
if (replace) { /* with replacement */
for (n = 0; n < nstrata; ++n) {
for (j = 0; j < sampsize[n]; ++j) {
ktmp = (int) (unif_rand() * strata_size[n]);
k = strata_idx[n][ktmp];
tclasspop[cl[k] - 1] += classwt[cl[k] - 1];
win[k] += classwt[cl[k] - 1];
jin[k] = 1;
}
}
} else { /* stratified sampling w/o replacement */
/* re-initialize the index array */
zeroInt(strata_size, nstrata);
for (j = 0; j < nsample; ++j) {
strata_size[strata[j] - 1] ++;
strata_idx[strata[j] - 1][strata_size[strata[j] - 1] - 1] = j;
}
/* sampling without replacement */
for (n = 0; n < nstrata; ++n) {
last = strata_size[n] - 1;
for (j = 0; j < sampsize[n]; ++j) {
ktmp = (int) (unif_rand() * (last+1));
k = strata_idx[n][ktmp];
swapInt(strata_idx[n][last], strata_idx[n][ktmp]);
last--;
tclasspop[cl[k] - 1] += classwt[cl[k]-1];
win[k] += classwt[cl[k]-1];
jin[k] = 1;
}
}
}
} else { /* unstratified sampling */
anyEmpty = 0;
ntry = 0;
do {
zeroInt(jin, nsample);
zeroDouble(tclasspop, nclass);
zeroDouble(win, nsample);
if (replace) {
for (n = 0; n < *sampsize; ++n) {
k = unif_rand() * nsample;
tclasspop[cl[k] - 1] += classwt[cl[k]-1];
win[k] += classwt[cl[k]-1];
jin[k] = 1;
}
} else {
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--;
tclasspop[cl[k] - 1] += classwt[cl[k]-1];
win[k] += classwt[cl[k]-1];
jin[k] = 1;
}
}
/* check if any class is missing in the sample */
for (n = 0; n < nclass; ++n) {
if (tclasspop[n] == 0) anyEmpty = 1;
}
ntry++;
} while (anyEmpty && ntry <= 10);
}
/* If need to keep indices of inbag data, do that here. */
if (keepInbag) {
for (n = 0; n < nsample0; ++n) {
inbag[n + idxByNsample] = jin[n];
}
}
/* Copy the original a matrix back. */
memcpy(a, at, sizeof(int) * mdim * nsample);
modA(a, &nuse, nsample, mdim, cat, *maxcat, ncase, jin);
#ifdef WIN64
F77_CALL(_buildtree)
#endif
#ifndef WIN64
F77_CALL(buildtree)
#endif
(a, b, cl, cat, maxcat, &mdim, &nsample,
&nclass,
treemap + 2*idxByNnode, bestvar + idxByNnode,
bestsplit, bestsplitnext, tgini,
nodestatus + idxByNnode, nodepop,
nodestart, classpop, tclasspop, tclasscat,
ta, nrnodes, idmove, &ndsize, ncase,
&mtry, varUsed, nodeclass + idxByNnode,
ndbigtree + jb, win, wr, wl, &mdim,
&nuse, mind);
/* if the "tree" has only the root node, start over */
} while (ndbigtree[jb] == 1);
Xtranslate(x, mdim, *nrnodes, nsample, bestvar + idxByNnode,
bestsplit, bestsplitnext, xbestsplit + idxByNnode,
nodestatus + idxByNnode, cat, ndbigtree[jb]);
/* Get test set error */
if (*testdat) {
predictClassTree(xts, ntest, mdim, treemap + 2*idxByNnode,
nodestatus + idxByNnode, xbestsplit + idxByNnode,
bestvar + idxByNnode,
nodeclass + idxByNnode, ndbigtree[jb],
cat, nclass, jts, nodexts, *maxcat);
TestSetError(countts, jts, clts, outclts, ntest, nclass, jb+1,
errts + jb*(nclass+1), labelts, nclts, cut);
}
/* Get out-of-bag predictions and errors. */
predictClassTree(x, nsample, mdim, treemap + 2*idxByNnode,
nodestatus + idxByNnode, xbestsplit + idxByNnode,
bestvar + idxByNnode,
nodeclass + idxByNnode, ndbigtree[jb],
cat, nclass, jtr, nodex, *maxcat);
zeroInt(nout, nclass);
noutall = 0;
for (n = 0; n < nsample; ++n) {
if (jin[n] == 0) {
/* increment the OOB votes */
counttr[n*nclass + jtr[n] - 1] ++;
/* count number of times a case is OOB */
out[n]++;
/* count number of OOB cases in the current iteration.
* nout[n] is the number of OOB cases for the n-th class.
* noutall is the number of OOB cases overall. */
nout[cl[n] - 1]++;
noutall++;
}
}
/* Compute out-of-bag error rate. */
oob(nsample, nclass, jin, cl, jtr, jerr, counttr, out,
errtr + jb*(nclass+1), outcl, cut);
if ((jb+1) % trace == 0) {
Rprintf("%5i: %6.2f%%", jb+1, 100.0*errtr[jb * (nclass+1)]);
for (n = 1; n <= nclass; ++n) {
Rprintf("%6.2f%%", 100.0 * errtr[n + jb * (nclass+1)]);
}
if (labelts) {
Rprintf("| ");
for (n = 0; n <= nclass; ++n) {
Rprintf("%6.2f%%", 100.0 * errts[n + jb * (nclass+1)]);
}
}
Rprintf("\n");
//R_CheckUserInterrupt();
}
/* DO VARIABLE IMPORTANCE */
if (imp) {
nrightall = 0;
/* Count the number of correct prediction by the current tree
* among the OOB samples, by class. */
zeroInt(nright, nclass);
for (n = 0; n < nsample; ++n) {
/* out-of-bag and predicted correctly: */
if (jin[n] == 0 && jtr[n] == cl[n]) {
nright[cl[n] - 1]++;
nrightall++;
}
}
for (m = 0; m < mdim; ++m) {
if (varUsed[m]) {
nrightimpall = 0;
zeroInt(nrightimp, nclass);
for (n = 0; n < nsample; ++n) tx[n] = x[m + n*mdim];
/* Permute the m-th variable. */
permuteOOB(m, x, jin, nsample, mdim);
/* Predict the modified data using the current tree. */
predictClassTree(x, nsample, mdim, treemap + 2*idxByNnode,
nodestatus + idxByNnode,
xbestsplit + idxByNnode,
bestvar + idxByNnode,
nodeclass + idxByNnode, ndbigtree[jb],
cat, nclass, jvr, nodex, *maxcat);
/* Count how often correct predictions are made with
* the modified data. */
for (n = 0; n < nsample; n++) {
if (jin[n] == 0) {
if (jvr[n] == cl[n]) {
nrightimp[cl[n] - 1]++;
nrightimpall++;
}
if (localImp && jvr[n] != jtr[n]) {
if (cl[n] == jvr[n]) {
impmat[m + n*mdim] -= 1.0;
} else {
impmat[m + n*mdim] += 1.0;
}
}
}
/* Restore the original data for that variable. */
x[m + n*mdim] = tx[n];
}
/* Accumulate decrease in proportions of correct
* predictions. */
for (n = 0; n < nclass; ++n) {
if (nout[n] > 0) {
imprt[m + n*mdim] +=
((double) (nright[n] - nrightimp[n])) /
nout[n];
impsd[m + n*mdim] +=
((double) (nright[n] - nrightimp[n]) *
(nright[n] - nrightimp[n])) / nout[n];
}
}
if (noutall > 0) {
imprt[m + nclass*mdim] +=
((double)(nrightall - nrightimpall)) / noutall;
impsd[m + nclass*mdim] +=
((double) (nrightall - nrightimpall) *
(nrightall - nrightimpall)) / noutall;
}
}
}
}
/* DO PROXIMITIES */
if (iprox) {
computeProximity(prox, oobprox, nodex, jin, oobpair, near);
/* proximity for test data */
if (*testdat) {
computeProximity(proxts, 0, nodexts, jin, oobpair, ntest);
/* Compute proximity between testset and training set. */
for (n = 0; n < ntest; ++n) {
for (k = 0; k < near; ++k) {
if (nodexts[n] == nodex[k])
proxts[n + ntest * (k+ntest)] += 1.0;
}
}
}
}
if (keepf) idxByNnode += *nrnodes;
if (keepInbag) idxByNsample += nsample0;
}
PutRNGstate();
/* Final processing of variable importance. */
for (m = 0; m < mdim; m++) tgini[m] /= Ntree;
if (imp) {
for (m = 0; m < mdim; ++m) {
if (localImp) { /* casewise measures */
for (n = 0; n < nsample; ++n) impmat[m + n*mdim] /= out[n];
}
/* class-specific measures */
for (k = 0; k < nclass; ++k) {
av = imprt[m + k*mdim] / Ntree;
impsd[m + k*mdim] =
sqrt(((impsd[m + k*mdim] / Ntree) - av*av) / Ntree);
imprt[m + k*mdim] = av;
/* imprt[m + k*mdim] = (se <= 0.0) ? -1000.0 - av : av / se; */
}
/* overall measures */
av = imprt[m + nclass*mdim] / Ntree;
impsd[m + nclass*mdim] =
sqrt(((impsd[m + nclass*mdim] / Ntree) - av*av) / Ntree);
imprt[m + nclass*mdim] = av;
imprt[m + (nclass+1)*mdim] = tgini[m];
}
} else {
for (m = 0; m < mdim; ++m) imprt[m] = tgini[m];
}
/* PROXIMITY DATA ++++++++++++++++++++++++++++++++*/
if (iprox) {
for (n = 0; n < near; ++n) {
for (k = n + 1; k < near; ++k) {
prox[near*k + n] /= oobprox ?
(oobpair[near*k + n] > 0 ? oobpair[near*k + n] : 1) :
Ntree;
prox[near*n + k] = prox[near*k + n];
}
prox[near*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 (trace <= Ntree){
printf("\nmdim %d, nclass %d, nrnodes %d, nsample %d, ntest %d\n", mdim, nclass, *nrnodes, nsample, ntest);
printf("\noobprox %d, mdim %d, nsample0 %d, Ntree %d, mtry %d, mimp %d", oobprox, mdim, nsample0, Ntree, mtry, mimp);
printf("\nstratify %d, replace %d",stratify,replace);
printf("\n");
}
//frees up the memory
free(tgini);free(wl);free(wr);free(classpop);free(tclasscat);
free(tclasspop);free(tx);free(win);free(tp);free(out);
free(bestsplitnext);free(bestsplit);free(nodepop);free(nodestart);free(jin);
free(nodex);free(nodexts);free(ta);free(ncase);free(jerr);
free(varUsed);free(jtr);free(jvr);free(classFreq);free(jts);
free(idmove);free(at);free(a);free(b);free(mind);
free(nright);free(nrightimp);free(nout);
if (oobprox) {
free(oobpair);
}
if (stratify) {
free(strata_size);
for (n = 0; n < nstrata; ++n) {
free(strata_idx[n]);
}
free(strata_idx);
} else {
if (replace)
free(nind);
}
//printf("labelts %d\n",labelts);fflush(stdout);
if (labelts) {
free(nclts);
}
//printf("stratify %d",stratify);fflush(stdout);
}
void SummStats(Edge n_edges, Vertex n_nodes, Vertex *tails, Vertex *heads,
Network *nwp, Model *m, double *stats, Network *y0){
Vertex *nodes; /*may need to change*/
nodes = (Vertex *)malloc( 1 * sizeof(Vertex));
GetRNGstate(); /* R function enabling uniform RNG */
ShuffleEdges(tails,heads,n_edges); /* Shuffle edgelist. */
for (unsigned int termi=0; termi < m->n_terms; termi++)
m->termarray[termi].dstats = m->workspace;
/* Doing this one toggle at a time saves a lot of toggles... */
for(Edge e=0; e<n_edges; e++){
ModelTerm *mtp = m->termarray;
double *statspos=stats;
nodes[0] = 0;
for (unsigned int termi=0; termi < m->n_terms; termi++, mtp++){
if(!mtp->s_func){
(*(mtp->d_func))(1, tails+e, heads+e, nodes,
mtp, nwp, y0); /* Call d_??? function */
for (unsigned int i=0; i < mtp->nstats; i++,statspos++)
*statspos += mtp->dstats[i];
}else statspos += mtp->nstats;
}
ToggleEdge(tails[e],heads[e],nwp);
}
/* Doing this one toggle at a time saves a lot of toggles... */
for(int v=0; v<n_nodes; v++){
if(m->nodalstatus[v]== 2.0){
nodes[0] = (int) (v+1);
ModelTerm *mtp = m->termarray;
double *statspos=stats;
for (unsigned int termi=0; termi < m->n_terms; termi++, mtp++){
if(!mtp->s_func){
(*(mtp->d_func))(1, tails, heads, nodes,
mtp, nwp, y0); /* Call d_??? function */
for (unsigned int i=0; i < mtp->nstats; i++,statspos++)
*statspos += mtp->dstats[i];
}else statspos += mtp->nstats;
}
ToggleNode(v+1,nwp);
}
}
ModelTerm *mtp = m->termarray;
double *dstats = m->workspace;
double *statspos=stats;
for (unsigned int termi=0; termi < m->n_terms; termi++, dstats+=mtp->nstats, mtp++ ){
if(mtp->s_func){
(*(mtp->s_func))(mtp, nwp); /* Call s_??? function */
for (unsigned int i=0; i < mtp->nstats; i++,statspos++)
*statspos = mtp->dstats[i];
}else statspos += mtp->nstats;
}
PutRNGstate();
}
void simStahl(int *n_sim, double *nu, double *p, double *L,
int *nxo, double *loc, int *max_nxo,
int *n_bins4start)
{
double **Loc, scale;
double curloc=0.0, u;
double *startprob, step;
int i, j, n_nixo;
/* re-organize loc as a doubly index array */
Loc = (double **)R_alloc(*n_sim, sizeof(double *));
Loc[0] = loc;
for(i=1; i < *n_sim; i++)
Loc[i] = Loc[i-1] + *max_nxo;
GetRNGstate();
if(fabs(*nu - 1.0) < 1e-8) { /* looks like a Poisson model */
for(i=0; i< *n_sim; i++) {
R_CheckUserInterrupt(); /* check for ^C */
nxo[i] = rpois(*L);
if(nxo[i] > *max_nxo)
error("Exceeded maximum number of crossovers.");
for(j=0; j < nxo[i]; j++)
Loc[i][j] = runif(0.0, *L);
}
}
else {
scale = 1.0 / (2.0 * *nu * (1.0 - *p));
/* set up starting distribution */
startprob = (double *)R_alloc(*n_bins4start, sizeof(double));
step = *L/(double)*n_bins4start;
startprob[0] = 2.0*(1.0 - *p)*pgamma(0.5*step, *nu, scale, 0, 0)*step;
for(i=1; i< *n_bins4start; i++) {
R_CheckUserInterrupt(); /* check for ^C */
startprob[i] = startprob[i-1] +
2.0*(1.0 - *p)*pgamma(((double)i+0.5)*step, *nu, scale, 0, 0)*step;
}
for(i=0; i< *n_sim; i++) {
R_CheckUserInterrupt(); /* check for ^C */
nxo[i] = 0;
/* locations of chiasmata from the gamma model */
/* shape = nu, rate = 2*nu*(1-p) [scale = 1/{2*nu*(1-p)}] */
u = unif_rand();
if( u > startprob[*n_bins4start-1] )
curloc = *L+1;
else {
for(j=0; j< *n_bins4start; j++) {
if(u <= startprob[j]) {
curloc = ((double)j+0.5)*step;
if(unif_rand() < 0.5) {
nxo[i] = 1;
Loc[i][0] = curloc;
}
break;
}
}
}
if(curloc < *L) {
while(curloc < *L) {
curloc += rgamma(*nu, scale);
if(curloc < *L && unif_rand() < 0.5) {
if(nxo[i] > *max_nxo)
error("Exceeded maximum number of crossovers.");
Loc[i][nxo[i]] = curloc;
(nxo[i])++;
}
}
}
/* locations of crossovers from the no interference mechanism */
if(*p > 0) {
n_nixo = rpois(*L * *p);
if(n_nixo + nxo[i] > *max_nxo)
error("Exceeded maximum number of crossovers.");
for(j=0; j < n_nixo; j++)
Loc[i][nxo[i]+j] = runif(0.0, *L);
nxo[i] += n_nixo;
}
}
}
/* sort the results */
for(i=0; i< *n_sim; i++)
R_rsort(Loc[i], nxo[i]);
PutRNGstate();
}
void random_permutation(int *n, int *sigma){
GetRNGstate();
Generic gen;
gen.generate_random_permutation(*n, FIRST_ITEM, sigma);
PutRNGstate();
}
void dirichlet_wrapper(int *n, double *epsilon)
{
GetRNGstate();
rdirich(*n, epsilon);
PutRNGstate();
}
void condsim(int* n, int* d, int* d1, double* u1, int* family, double* par, double* nu, double* out)
{
int i,j, k;
double **uf,**ub,**th,**nuu;
double aux;
int **fam;
uf = create_matrix(*d,*d);
ub = create_matrix(*d,*d);
th = create_matrix(*d+1,*d+1);
nuu = create_matrix(*d+1,*d+1);
fam = create_intmatrix(*d+1,*d+1);
// param in matrices:
k = 0;
for(i=0;i<((*d)-1);i++)
{
for(j=0;j<((*d)-i-1);j++)
{
fam[i][j] = family[k];
nuu[i][j] = nu[k];
th[i][j] = par[k];
k++;
//printf("%d \t",fam[i][j]);
}
//printf("\n");
}
// Simulation
GetRNGstate();
/*
Declare variable to hold seconds on clock.
*/
//time_t seconds;
/*
Get value from system clock and
place in seconds variable.
*/
//time(&seconds);
/*
Convert seconds to a unsigned
integer.
*/
//srand((unsigned int) seconds);
// for i = 0
uf[0][0] = u1[0];
ub[0][0] = u1[0];
// for i = 1,... d1-1
// compute uf and ub
for (int i = 1; i < (*d1); ++i)
{
uf[i][i] = u1[i];
ub[i][i] = u1[i];
for (int j = (i-1); j >= 0; --j)
{
Hfunc(&fam[i-j-1][j],n,&ub[i][j+1], &uf[i-1][j],&th[i-j-1][j],&nuu[i-j-1][j],&ub[i][j]); //backward
//printf("ub: %d,%d : %d, %5.2f : %10.8f \n",i,j,fam[i-j-1][j], th[i-j-1][j], ub[i][j]);
}
//printf("\n");
for (int j = 0; j <= i-1; ++j)
{
Hfunc(&fam[i-j-1][j],n, &uf[i-1][j], &ub[i][j+1],&th[i-j-1][j],&nuu[i-j-1][j],&uf[i][j]); //forward
//printf("uf: %d,%d : %d, %5.2f : %10.8f \n",i,j,fam[i-j-1][j], th[i-j-1][j], uf[i][j]);
}
//printf("\n");
}
// for i= d1,.. d-1
for (int i = (*d1); i < (*d); ++i)
{
// (a) Simulate uniform
//out[i-(*d1)] = rand()/(RAND_MAX+1.0);
out[i-(*d1)]=runif(0,1);
// (b) inverse transformation:
for (int j = 0; j < i; ++j)
{
//printf("inv: %d,%d : %d, %5.2f : %10.8f \t",i-j-1,j,fam[i-j-1][j], th[i-j-1][j], uf[i-1][j]);
Hinv(&fam[i-j-1][j], n, &out[i-*d1] , &uf[i-1][j], &th[i-j-1][j], &nuu[i-j-1][j],&aux );
out[i-(*d1)] = aux;
//printf("%10.8f \n ", aux);
}
//printf("\n");
if (i <((*d)-1))
{
// forward and backward steps:
uf[i][i] = out[i-(*d1)];
ub[i][i] = out[i-(*d1)];
for (int j = i-1; j >= 0; --j)
{
Hfunc(&fam[i-j-1][j],n,&ub[i][j+1], &uf[i-1][j],&th[i-j-1][j],&nuu[i-j-1][j],&ub[i][j]); //backward
//printf("ub: %d,%d : %d, %5.2f : %10.8f \n",i-j-1,j,fam[i-j-1][j], th[i-j-1][j], ub[i][j]);
}
//printf("\n");
for (int j = 0; j <= i-1; ++j)
{
Hfunc(&fam[i-j-1][j],n, &uf[i-1][j], &ub[i][j+1],&th[i-j-1][j],&nuu[i-j-1][j],&uf[i][j]); //forward
//printf("uf: %d,%d : %d, %5.2f : %10.8f \n",i-j-1,j,fam[i-j-1][j], th[i-j-1][j], uf[i][j]);
}
//printf("\n");
}
}
// free memory
free_matrix(th,*d);
free_matrix(ub,*d);
free_matrix(uf,*d);
free_matrix(nuu,*d);
free_intmatrix(fam,*d);
PutRNGstate();
}
void rgeomtbm(double *coord, int *nObs, int *nSite, int *dim,
int *covmod, int *grid, double *sigma2, double *nugget,
double *range, double *smooth, double *uBound,
int *nlines, double *ans){
/* This function generates random fields from the geometric model
coord: the coordinates of the locations
nObs: the number of observations to be generated
nSite: the number of locations
dim: the random field is generated in R^dim
covmod: the covariance model
grid: Does coord specifies a grid?
sigma2: the variance of the geometric gaussian process
nugget: the nugget parameter
range: the range parameter
smooth: the smooth parameter
uBound: the uniform upper bound for the stoch. proc.
nlines: the number of lines used in the TBM algo
ans: the generated random field */
int i, neffSite, lagi = 1, lagj = 1;
const double loguBound = log(*uBound), halfSigma2 = 0.5 * *sigma2;
double sigma = sqrt(*sigma2), sill = 1 - *nugget;
if (*grid){
neffSite = R_pow_di(*nSite, *dim);
lagi = neffSite;
}
else{
neffSite = *nSite;
lagj = *nObs;
}
double *gp = malloc(neffSite * sizeof(double)),
*lines = malloc(3 * *nlines * sizeof(double));
//rescale the coordinates
for (i=(*nSite * *dim);i--;){
const double irange = 1 / *range;
coord[i] = coord[i] * irange;
}
if ((*covmod == 3) && (*smooth == 2))
//This is the gaussian case
*covmod = 5;
//Generate lines
vandercorput(nlines, lines);
GetRNGstate();
for (i=*nObs;i--;){
int nKO = neffSite;
double poisson = 0;
while (nKO) {
/* The stopping rule is reached when nKO = 0 i.e. when each site
satisfies the condition in Eq. (8) of Schlather (2002) */
int j;
/* ------- Random rotation of the lines ----------*/
double u = unif_rand() - 0.5,
v = unif_rand() - 0.5,
w = unif_rand() - 0.5,
angle = runif(0, M_2PI),
inorm = 1 / sqrt(u * u + v * v + w * w);
u *= inorm;
v *= inorm;
w *= inorm;
rotation(lines, nlines, &u, &v, &w, &angle);
/* -------------- end of rotation ---------------*/
poisson += exp_rand();
double ipoisson = -log(poisson),
thresh = loguBound + ipoisson;
/* We simulate one realisation of a gaussian random field with
the required covariance function */
for (j=neffSite;j--;)
gp[j] = 0;
tbmcore(nSite, &neffSite, dim, covmod, grid, coord, nugget,
&sill, range, smooth, nlines, lines, gp);
nKO = neffSite;
double ipoissonMinusHalfSigma2 = ipoisson - halfSigma2;
for (j=neffSite;j--;){
ans[j * lagj + i * lagi] = fmax2(sigma * gp[j] + ipoissonMinusHalfSigma2,
ans[j * lagj + i * lagi]);
nKO -= (thresh <= ans[j * lagj + i * lagi]);
}
}
}
PutRNGstate();
/* So far we generate a max-stable process with standard Gumbel
margins. Switch to unit Frechet ones */
for (i=*nObs * neffSite;i--;)
ans[i] = exp(ans[i]);
free(lines); free(gp);
return;
}
SEXP predosnnet (SEXP s_n, SEXP s_nconn, SEXP s_conn, SEXP s_decay, SEXP s_nsunits,
SEXP s_entropy, SEXP s_softmax, SEXP s_censored,
SEXP s_ntr, SEXP s_train, SEXP s_Nw, SEXP s_wts, SEXP s_random,
SEXP s_rang, SEXP s_Fmin, SEXP s_maxit, SEXP s_trace, SEXP s_mask,
SEXP s_abstol, SEXP s_reltol, SEXP s_ifail,
SEXP s_ntest, SEXP s_nout, SEXP s_test,
SEXP s_wf, SEXP s_bw, SEXP s_k, SEXP s_env
) {
int i, j, l; // indices
/* unpack R input */
Sint *n = INTEGER(s_n); // information about # units in net
Sint *ntr = INTEGER(s_ntr); // # of training observations
Sdata *train = REAL(s_train); // pointer to training data set
/*for (i = 0; i < 3; i++) {
Rprintf("n %u \n", n[i]);
}
Rprintf("ntr %u \n", *ntr);*/
Sint *ntest = INTEGER(s_ntest); // # of test observations
Sint *nout = INTEGER(s_nout); // # of output units
Sdata *test = REAL(s_test); // pointer to test data set
R_len_t p = ncols(s_test); // # of predictors
/*Rprintf("ntest %u \n", *ntest);
Rprintf("nout %u \n", *nout);
Rprintf("p %u \n", p);*/
double *Fmin = REAL(s_Fmin); //
double *wts = REAL(s_wts); // pointer to initial weights
int random = LOGICAL(s_random)[0]; // initialize weights randomly?
Sint *Nw = INTEGER(s_Nw); // # of weights
double iwts[*Nw]; // array for saving initial weights if passed
double rang = 0; // parameter of uniform distribution for random initialization of weights
if (random) {
rang = REAL(s_rang)[0]; // parameter for uniform distribution
//Rprintf("rang %f \n", rang);
} else { // save initial weights
for (i = 0; i < *Nw; i++) {
iwts[i] = wts[i];
}
}
/*Rprintf("Fmin %f \n", *Fmin);
Rprintf("random %u \n", random);
Rprintf("Nw %u \n", *Nw);*/
SEXP s_dist; // initialize distances to test observation
PROTECT(s_dist = allocVector(REALSXP, *ntr));
double *dist = REAL(s_dist);
SEXP s_weights; // initialize case weight vector
PROTECT(s_weights = allocVector(REALSXP, *ntr));
Sdata *weights = REAL(s_weights);
double sum_weights = 0.0; // sum of observation weights for normalization of weights
SEXP s_result; // initialize matrix for raw values
PROTECT(s_result = allocMatrix(REALSXP, *ntest, *nout));
Sdata *result = REAL(s_result);
/* select weight function */
typedef void (*wf_ptr_t) (double*, double*, int, double*, int);// *w, *dist, N, *bw, k
wf_ptr_t wf = NULL;
if (isInteger(s_wf)) {
const int wf_nr = INTEGER(s_wf)[0];
wf_ptr_t wfs[] = {biweight1, cauchy1, cosine1, epanechnikov1, exponential1, gaussian1,
optcosine1, rectangular1, triangular1, biweight2, cauchy2, cosine2, epanechnikov2,
exponential2, gaussian2, optcosine2, rectangular2, triangular2, biweight3, cauchy3,
cosine3, epanechnikov3, exponential3, gaussian3, optcosine3, rectangular3,
triangular3, cauchy4, exponential4, gaussian4};
wf = wfs[wf_nr - 1];
}
/* set net */
VR_set_net(n, INTEGER(s_nconn), INTEGER(s_conn),
REAL(s_decay), INTEGER(s_nsunits), INTEGER(s_entropy),
INTEGER(s_softmax), INTEGER(s_censored));
/*VR_set_net(Sint *n, Sint *nconn, Sint *conn,
double *decay, Sint *nsunits, Sint *entropy,
Sint *softmax, Sint *censored); */
/*for (i = 0; i <= 11; i++)
Rprintf("s_nconn %u \n", INTEGER(s_nconn)[i]);
Rprintf("Nunits %u \n", Nunits);*/
GetRNGstate();
/* loop over test observations */
for (l = 0; l < *ntest; l++) {
//Rprintf("Nweights %u\n", Nweights);
/* initialize weights */
if (random) { // generate initial weights randomly
for (i = 0; i < *Nw; i++) {
wts[i] = runif(-rang, rang);
//Rprintf("wts %f\n", wts[i]);
}
} else { // restore initial weights
for (i = 0; i < *Nw; i++) {
wts[i] = iwts[i];
//Rprintf("wts %f\n", wts[i]);
}
}
/* reinitialize stuff */
*Fmin = 0.0;
Epoch = 0;
TotalError = 0.0;
sum_weights = 0.0;
/* calculate distances to n-th test observation */
for (i = 0; i < *ntr; i++) {
dist[i] = 0;
for (j = 0; j < p; j++) {
dist[i] += pow(train[i + *ntr * j] - test[l + *ntest * j], 2);
}
dist[i] = sqrt(dist[i]);
weights[i] = 0;
//Rprintf("dist %f\n", dist[i]);
}
/* calculate observation weights */
if (isInteger(s_wf)) {
// case 1: wf is integer
// calculate weights by reading number and calling corresponding C function
wf (weights, dist, *ntr, REAL(s_bw), INTEGER(s_k)[0]);
} else if (isFunction(s_wf)) {
// case 2: wf is R function
// calculate weights by calling R function
SEXP R_fcall;
PROTECT(R_fcall = lang2(s_wf, R_NilValue));
SETCADR(R_fcall, s_dist);
weights = REAL(eval(R_fcall, s_env));
UNPROTECT(1); // R_fcall
}
/* rescale weights such that they sum up to *ntr */
for(i = 0; i < *ntr; i++) {
sum_weights += weights[i];
//Rprintf("weights %f\n", weights[i]);
}
for(i = 0; i < *ntr; i++) {
weights[i] = weights[i]/sum_weights * *ntr; // ?numerical problems, 0/0?
//Rprintf("weights %f\n", weights[i]);
}
/* train net */
VR_dovm(ntr, train, weights,
Nw, wts, Fmin,
INTEGER(s_maxit), INTEGER(s_trace), INTEGER(s_mask),
REAL(s_abstol), REAL(s_reltol), INTEGER(s_ifail));
/*VR_dovm(Sint *ntr, Sdata *train, Sdata *weights,
Sint *Nw, double *wts, double *Fmin,
Sint *maxit, Sint *trace, Sint *mask,
double *abstol, double *reltol, int *ifail);*/
/*for (i = 0; i < *Nw; i++) {
Rprintf("wts %f\n", wts[i]);
}*/
/* predict l-th test observation */
VR_nntest2(ntest, test, result, wts, l);
/*VR_nntest(Sint *ntest, Sdata *test, Sdata *result, double *wts);*/
}
// end loop over test observations
/* cleaning up */
VR_unset_net();
PutRNGstate();
UNPROTECT(3); // s_dist, s_w, s_result
return(s_result);
}
SEXP allfaces(SEXP hrep)
{
GetRNGstate();
if (! isMatrix(hrep))
error("'hrep' must be matrix");
if (! isString(hrep))
error("'hrep' must be character");
SEXP hrep_dim;
PROTECT(hrep_dim = getAttrib(hrep, R_DimSymbol));
int nrow = INTEGER(hrep_dim)[0];
int ncol = INTEGER(hrep_dim)[1];
UNPROTECT(1);
if (nrow <= 0)
error("no rows in 'hrep'");
if (ncol <= 3)
error("three or fewer cols in hrep");
for (int i = 0; i < nrow; ++i) {
const char *foo = CHAR(STRING_ELT(hrep, i));
if (strlen(foo) != 1)
error("column one of 'hrep' not zero-or-one valued");
if (! (foo[0] == '0' || foo[0] == '1'))
error("column one of 'hrep' not zero-or-one valued");
}
dd_set_global_constants();
/* note actual type of "value" is mpq_t (defined in cddmp.h) */
mytype value;
dd_init(value);
dd_MatrixPtr mf = dd_CreateMatrix(nrow, ncol - 1);
/* note our matrix has one more column than Fukuda's */
mf->representation = dd_Inequality;
mf->numbtype = dd_Rational;
/* linearity */
for (int i = 0; i < nrow; ++i) {
const char *foo = CHAR(STRING_ELT(hrep, i));
if (foo[0] == '1')
set_addelem(mf->linset, i + 1);
/* note conversion from zero-origin to one-origin indexing */
}
/* matrix */
for (int j = 1, k = nrow; j < ncol; ++j)
for (int i = 0; i < nrow; ++i, ++k) {
const char *rat_str = CHAR(STRING_ELT(hrep, k));
if (mpq_set_str(value, rat_str, 10) == -1) {
dd_FreeMatrix(mf);
dd_clear(value);
dd_free_global_constants();
error("error converting string to GMP rational");
}
mpq_canonicalize(value);
dd_set(mf->matrix[i][j - 1], value);
/* note our matrix has one more column than Fukuda's */
}
SEXP result;
PROTECT(result = FaceEnum(mf));
dd_FreeMatrix(mf);
dd_clear(value);
dd_free_global_constants();
if (result == R_NilValue)
error("failed");
PutRNGstate();
UNPROTECT(1);
return result;
}
cs *cs_inv(const cs *C){
int n, i, icol,irow,j,k,l,ll;
double big,dum,pivinv,temp, det, CN;
CN = cs_norm(C);
cs *A;
n = C->n;
det=1.0;
int indxc[n],
indxr[n],
ipiv[n];
A = cs_spalloc (n, n, n*n, 1, 0);
if (!A ) return (cs_done (A, NULL, NULL, 0));
for(i = 0; i<(n*n); i++){
A->i[i] = C->i[i];
A->x[i] = C->x[i];
}
for(i = 0; i<=n; i++){
A->p[i] = C->p[i];
}
for (j=0;j<n;j++) ipiv[j]=0;
for (i=0;i<n;i++) {
big=0.0;
for (j=0;j<n;j++)
if (ipiv[j] != 1)
for (k=0;k<n;k++) {
if (ipiv[k] == 0) {
if (fabs(A->x[A->i[j]+A->p[k]]) >= big) {
big=fabs(A->x[A->i[j]+A->p[k]]);
irow=j;
icol=k;
}
} else if (ipiv[k] > 1) error("Singular G/R structure: use proper priors\n");// //exit(1);
}
++(ipiv[icol]);
if (irow != icol) {
for (l=0;l<n;l++){
temp = A->x[A->i[irow]+A->p[l]];
A->x[A->i[irow]+A->p[l]] = A->x[A->i[icol]+A->p[l]];
A->x[A->i[icol]+A->p[l]]= temp;
}
}
indxr[i]=irow;
indxc[i]=icol;
det *= A->x[A->i[icol]+A->p[icol]];
pivinv = 1.0/(A->x[A->i[icol]+A->p[icol]]);
A->x[A->i[icol]+A->p[icol]]=1.0;
for (l=0;l<n;l++) A->x[A->i[icol]+A->p[l]] *= pivinv;
for (ll=0;ll<n;ll++)
if (ll != icol) {
dum=A->x[A->i[ll]+A->p[icol]];
A->x[A->i[ll]+A->p[icol]]=0.0;
for (l=0;l<n;l++) A->x[A->i[ll]+A->p[l]] -= A->x[A->i[icol]+A->p[l]]*dum;
}
}
for (l=(n-1);l>=0;l--) {
if (indxr[l] != indxc[l]){
for (k=0;k<n;k++){
temp = A->x[A->i[k]+A->p[indxr[l]]];
A->x[A->i[k]+A->p[indxr[l]]] = A->x[A->i[k]+A->p[indxc[l]]];
A->x[A->i[k]+A->p[indxc[l]]] = temp;
}
}
}
CN *= cs_norm(A);
if(1.0/fabs(CN) < DBL_EPSILON){
if(n==1){
A->x[0] = 1.0/DBL_EPSILON;
}else{
PutRNGstate();
error("ill-conditioned G/R structure (CN = %f): use proper priors if you haven't or rescale data if you have\n", CN);
}
}
return (cs_done (A, NULL, NULL, 1)) ; /* success; free workspace, return C */
}
void MCMCPhase12 (int *tails, int *heads, int *dnedges,
int *dn, int *dflag, int *bipartite,
int *nterms, char **funnames,
char **sonames,
char **MHproposaltype, char **MHproposalpackage,
double *inputs,
double *theta0, int *samplesize,
double *gain, double *meanstats, int *phase1, int *nsub,
double *sample, int *burnin, int *interval,
int *newnetworktails,
int *newnetworkheads,
int *fVerbose,
int *attribs, int *maxout, int *maxin, int *minout,
int *minin, int *condAllDegExact, int *attriblength,
int *maxedges,
int *mtails, int *mheads, int *mdnedges) {
int directed_flag;
int nphase1, nsubphases;
Vertex n_nodes, bip;
Edge n_edges, nmax;
Network nw[2];
Model *m;
MHproposal MH;
nphase1 = *phase1;
nsubphases = *nsub;
n_nodes = (Vertex)*dn;
n_edges = (Edge)*dnedges;
nmax = (Edge)*maxedges;
bip = (Vertex)*bipartite;
GetRNGstate(); /* R function enabling uniform RNG */
directed_flag = *dflag;
m=ModelInitialize(*funnames, *sonames, &inputs, *nterms);
/* Form the missing network */
nw[0]=NetworkInitialize(tails, heads, n_edges,
n_nodes, directed_flag, bip, 0, 0, NULL);
MH_init(&MH,
*MHproposaltype, *MHproposalpackage,
inputs,
*fVerbose,
nw, attribs, maxout, maxin, minout, minin,
*condAllDegExact, *attriblength);
MCMCSamplePhase12 (&MH,
theta0, *gain, meanstats, nphase1, nsubphases, sample, *samplesize,
*burnin, *interval,
(int)*fVerbose, nw, m);
MH_free(&MH);
/* record new generated network to pass back to R */
if(nmax>0 && newnetworktails && newnetworkheads)
newnetworktails[0]=newnetworkheads[0]=EdgeTree2EdgeList(newnetworktails+1,newnetworkheads+1,nw,nmax-1);
ModelDestroy(m);
NetworkDestroy(nw);
PutRNGstate(); /* Disable RNG before returning */
}
// R-werte Gross und c-variablen klein
SEXP eiIndiMDGmulti(SEXP C, SEXP R, SEXP AGGPREC,
SEXP ALPHAS, SEXP BETAS,
SEXP TDF, SEXP ZRC, SEXP XDF, SEXP NDF,
SEXP LA1, SEXP LA2, SEXP ALPHAVARS, SEXP BETAVARS,
SEXP BURNIN, SEXP THINNING, SEXP SAMPLE,
SEXP VERBOSE, SEXP RETBETA){
////////////////////////////////////////////////////////////
////////// Einlesen und Umwandeln aller Vektoren und Werte
int c, r, aggp;
c=INTEGER(C)[0];
r=INTEGER(R)[0];
aggp=INTEGER(AGGPREC)[0];
// int n[aggp];
// for(int i=0;i<aggp;i++)
// n[i]=INTEGER(N)[i];
double alphas[r*c], betas[r*c*aggp], counts[r*c];
for(int i=0;i<r*c;i++)
alphas[i]=REAL(ALPHAS)[i];
for(int i=0;i<r*c*aggp;i++)
betas[i]=REAL(BETAS)[i];
int tdf[c*aggp];
for(int i=0;i<c*aggp;i++)
tdf[i]=INTEGER(TDF)[i];
int zrc[r*c*aggp];
for(int i=0;i<r*c*aggp;i++)
zrc[i]=INTEGER(ZRC)[i];
double xdf[r*aggp];
for(int i=0;i<r*aggp;i++)
xdf[i]=REAL(XDF)[i];
int ndf[r*aggp];
for(int i=0; i<r*aggp; i++)
ndf[i]=INTEGER(NDF)[i];
double la1[r*c], la2[r*c];
for(int i=0;i<r*c;i++)
la1[i]=REAL(LA1)[i];
for(int i=0;i<r*c;i++)
la2[i]=REAL(LA2)[i];
double alphaVars[r*c], betaVars[r*(c-1)*aggp];
for(int i=0;i<r*c;i++)
alphaVars[i]=REAL(ALPHAVARS)[i];
for(int i=0;i<r*(c-1)*aggp;i++){
betaVars[i]=REAL(BETAVARS)[i];
// Rprintf("%f", betaVars[i]);
}
int iter, burnin, thin, sample;
burnin=INTEGER(BURNIN)[0];
thin =INTEGER(THINNING)[0];
sample=INTEGER(SAMPLE)[0];
iter=burnin + thin*sample;
int verbose;
verbose = INTEGER(VERBOSE)[0];
int retbeta;
retbeta = INTEGER(RETBETA)[0];
SEXP betaret, alpharet, countsret;
PROTECT(betaret = allocMatrix(REALSXP, sample, r*c*aggp));
PROTECT(alpharet= allocMatrix(REALSXP, sample, r*c));
PROTECT(countsret = allocMatrix(REALSXP,sample,r*c));
for(int ii=0; ii<sample;ii++){
for(int qq=0; qq<r*c*aggp; qq++){
REAL(betaret)[ii + qq*sample]=-1;
// Rprintf("%f -- ", REAL(betaret)[itercurr+1 + qq*sample]);
}
}
SEXP alpha_acc, beta_acc;
PROTECT(alpha_acc = allocVector(REALSXP, r*c));
PROTECT(beta_acc = allocVector(REALSXP, r*(c-1)*aggp));
for(int qq=0; qq<r*c; qq++){
REAL(alpha_acc)[qq] = 0;
}
for(int qq=0; qq<r*(c-1)*aggp; qq++){
REAL(beta_acc)[qq] = 0;
}
GetRNGstate();
//Beginn des Metropolis Algorithmus
double betacurr, betarefcurr, betasumcurr, betarefsumcurr;
double betanew, betarefnew, betasumnew, betarefsumnew;
double llbetacurr, llbetanew;
double u;
double alphacurr,alphasumcurr;
double alphanew,alphasumnew;
double logbetasum[r*c];
double llalphacurr, llalphanew;
int itercurr =0;
int ii,pp,rr,cc;
double tmp; //sumcounter
for(ii=0; ii<iter;ii++){
for(pp=0; pp<aggp; pp++){
for(rr=0; rr<r; rr++){
for(cc=0; cc<(c-1); cc++){
// int pp,rr,cc;
// pp=4;
// rr=1;
// cc=2;
// Rprintf("i=%0d -- r=%0d -- c=%0d\n",pp,rr,cc);
betacurr = betas[r*c*pp + rr + r*cc];
betarefcurr =betas[r*c*pp + rr + r*(c-1)];
// \sum_r^R beta_rC * X_r
//evtl das vor die iterationschleife, da es nur aggp elemente sind
// Rprintf("%f %f %f\n", betacurr, betarefcurr,betarefsumcurr);
betanew = rnorm(betacurr, betaVars[r*(c-1)*pp + rr + r*cc]);
// Rprintf("%f - ", betanew);
betarefnew = betacurr+betarefcurr - betanew;
// \sum_r^R beta_rC * X_r (old) - beta^rC(old)*Xr + beta^rC(new)*Xr
// Rprintf("%f %f\n", betacurr, betarefsumcurr);
// Rprintf("%f %f\n", betanew,betarefsumnew);
// muss zwischen 0 und referenz+aktuell sein bspl 0.2 0.3, 0.1.
// 0.2 soll ersetzt werden und hat somit zwischen 0 und 0.6 "Platz"
// 0.6 =referenz+aktuell=0.4+0.2
if((betanew>0) & (betanew<(betarefcurr+betacurr))){
betasumcurr=0;
betasumnew=0;
betarefsumcurr=0;
for(int qq=0;qq<r;qq++){
betasumcurr +=betas[r*c*pp + qq + r*cc] * xdf[qq + (aggp-1)*qq + pp];
betarefsumcurr += betas[r*c*pp + qq + r*(c-1)] * xdf[qq + (aggp-1)*qq + pp];
}
betasumnew = betasumcurr - betacurr*xdf[rr+(aggp-1)*rr+pp] +
betanew*xdf[rr+(aggp-1)*rr+pp];
betarefsumnew = betarefsumcurr - betarefcurr*xdf[rr+(aggp-1)*rr+pp] +
betarefnew*xdf[rr+(aggp-1)*rr+pp];
// Rprintf("%f %f\n", betacurr, betasumcurr);
// Rprintf("%f %f\n", betanew,betasumnew);
// Rprintf("Zrc %d -- ZrC %d\n", zrc[r*c*pp + rr + r*cc], zrc[r*c*pp + rr + r*(c-1)]);
// Rprintf("logbetarc %f -- logbetarC %f\n", log(betacurr), log(betarefcurr));
// Rprintf("Tc %d -- TC %d\n", tdf[pp + (aggp-1)*cc + cc], tdf[pp+(aggp-1)*(c-1)+(c-1)]); //1695
// Rprintf("logsumx %f -- logsumxref %f\n", log(betasumcurr),log(betarefsumcurr) );
// Rprintf("alpha_rc %f -- alphaRC %f", alphas[rr+r*cc],alphas[rr+r*(c-1)]);
// Rprintf("\n");
llbetacurr = llBeta(zrc[r*c*pp + rr + r*cc], zrc[r*c*pp + rr + r*(c-1)],
betacurr, betarefcurr,
tdf[pp + (aggp-1)*cc + cc], tdf[pp+(aggp-1)*(c-1)+(c-1)],
betasumcurr, betarefsumcurr,
alphas[rr+r*cc],alphas[rr+r*(c-1)]);
llbetanew = llBeta(zrc[r*c*pp + rr + r*cc], zrc[r*c*pp + rr + r*(c-1)],
betanew, betarefnew,
tdf[pp + (aggp-1)*cc + cc], tdf[pp+(aggp-1)*(c-1)+(c-1)],
betasumnew, betarefsumnew,
alphas[rr+r*cc],alphas[rr+r*(c-1)]);
u=log(runif(0,1));
if(u< llbetanew-llbetacurr){
betas[r*c*pp + rr + r*cc] = betanew;
betas[r*c*pp + rr + r*(c-1)] = betarefnew;
// Rprintf("%f %f - ",betanew,betarefnew);
REAL(beta_acc)[r*(c-1)*pp + rr + r*cc] += 1;
}
// Rprintf("%f %f - ", betas[r*c*pp + rr + r*cc], betas[r*c*pp + rr + r*(c-1)]);
}
}
}
}
// sum_1:P log(\beta_i^rc)
for(rr=0; rr<r; rr++){
for(cc=0; cc<c; cc++){
tmp=0;
for(int qq=0; qq<aggp; qq++){
tmp += log(betas[r*c*qq + rr + r*cc]);
}
logbetasum[rr+cc*r] = tmp;
// Rprintf("%f ", logbetasum[rr+cc*r]);
// Rprintf("\n");
}
}
for(rr=0; rr<r; rr++){
for(cc=0; cc<c; cc++){
alphacurr = alphas[rr+cc*r];
alphanew = rnorm(alphacurr,alphaVars[rr+cc*r]);
// Rprintf("%f - ", alphanew);
alphasumcurr = 0;
for(int qq=0; qq<c; qq++){ // \sum_c:C \alpha^rc)
alphasumcurr += alphas[rr+qq*r];
}
alphasumnew = alphasumcurr - alphacurr + alphanew;
if(alphanew>0){
// Rprintf("%f %f -- ",la1[rr+cc*r],la2[rr+cc*r]);
llalphacurr = llAlphaGamma(aggp, alphasumcurr, alphacurr, logbetasum[rr+cc*r], la1[rr+cc*r],la2[rr+cc*r]);
llalphanew = llAlphaGamma(aggp, alphasumnew, alphanew, logbetasum[rr+cc*r], la1[rr+cc*r],la2[rr+cc*r]);
// Rprintf("%f\n",llalphanew);
u=log(runif(0,1));
// Rprintf("%f -- ",alphacurr);
if(u< llalphanew-llalphacurr){
alphas[rr+cc*r] = alphanew;
REAL(alpha_acc)[rr+cc*r] +=1;
}
// Rprintf("%f - ",alphas[rr+cc*r]);
}
}
// Rprintf("\n");
}
// Rprintf("%d ", ii>=burnin && ((ii+1) % thin)==0);
// Rprintf("%d - ", (ii+1) % thin);
if(ii==0 && ii==burnin){
Rprintf("no Burnin\n");
}
if(ii==0 && ii!=burnin){
Rprintf("Burnin start\n");
}
if((ii+1)==(burnin/2) && burnin>1000){
Rprintf("Burnin half time\n");
}
if((ii+1)==(burnin)){
Rprintf("Burnin finished\n");
}
if(ii>=burnin && (ii % thin)==0){
// Berechnung der cellCounts
for(int rrr=0; rrr<r; rrr++){
for(int ccc=0; ccc<c; ccc++){
tmp=0;
for(int qq=0; qq<aggp; qq++){
tmp += betas[rrr + r*ccc + r*c*qq]*ndf[qq+aggp*rrr];
// Rprintf("%f x %d--", betas[rrr + r*ccc + r*c*qq],ndf[qq+aggp*rrr]);
}
counts[rrr + r*ccc] = tmp;
}
}
if((itercurr+1)%verbose == 0)
Rprintf("%2d von %d\n", itercurr+1,sample);
// zeilen sind iterationen
for(int qq=0; qq<r*c*aggp; qq++){
REAL(betaret)[itercurr + qq*sample]=betas[qq];
// Rprintf("%f -- ", REAL(betaret)[itercurr+1 + qq*sample]);
}
for(int qq=0; qq<r*c; qq++){
REAL(alpharet)[itercurr+qq*sample]=alphas[qq];
REAL(countsret)[itercurr+qq*sample]=counts[qq];
// Rprintf("%f ",alphas[qq]);
}
itercurr++;
}
R_CheckUserInterrupt();
}
for(int qq=0; qq < r*c; qq++){
REAL(alpha_acc)[qq] = REAL(alpha_acc)[qq]/iter;
}
for(int qq=0; qq < r*(c-1)*aggp; qq++){
REAL(beta_acc)[qq] = REAL(beta_acc)[qq]/iter;
}
// Liste erstellen
SEXP ret;
if(retbeta==0){
int listlength=4;
PROTECT(ret = allocVector(VECSXP, listlength));
SET_VECTOR_ELT(ret,0,alpharet);
SET_VECTOR_ELT(ret,1,countsret);
SET_VECTOR_ELT(ret,2,alpha_acc);
SET_VECTOR_ELT(ret,3,beta_acc);
// Listennamen geben
SEXP ret_names;
PROTECT(ret_names=allocVector(STRSXP,listlength));
char *retnames[4] ={"alphaDraws","cellCounts","alphaAcc","betaAcc"};
for(int i=0;i<listlength;i++){
SET_STRING_ELT(ret_names,i,mkChar(retnames[i]));
}
setAttrib(ret, R_NamesSymbol,ret_names);
} else {
int listlength=5;
PROTECT(ret = allocVector(VECSXP, listlength));
SET_VECTOR_ELT(ret,0,betaret);
SET_VECTOR_ELT(ret,1,alpharet);
SET_VECTOR_ELT(ret,2,countsret);
SET_VECTOR_ELT(ret,3,alpha_acc);
SET_VECTOR_ELT(ret,4,beta_acc);
// Listennamen geben
SEXP ret_names;
PROTECT(ret_names=allocVector(STRSXP,listlength));
char *retnames[5] ={"betaDraws","alphaDraws","cellCounts","alphaAcc","betaAcc"};
for(int i=0;i<listlength;i++){
SET_STRING_ELT(ret_names,i,mkChar(retnames[i]));
}
setAttrib(ret, R_NamesSymbol,ret_names);
}
PutRNGstate();
UNPROTECT(7);
return ret;
// return(R_NilValue);
}
// For lots of subsets of size nwhich, compute the exact fit to those data
// points and the residuals from all the data points.
// copied with modification from MASS/src/lqs.c
// Copyright (C) 1998-2007 B. D. Ripley
// Copyright (C) 1999 R Development Core Team
// TODO: rewrite
void LQSEstimator::operator()(const Data& data, double* coef_ptr,
double* fitted_ptr, double* resid_ptr,
double* scale_ptr) {
int nnew = nwhich, pp = p;
int i, iter, nn = n, trial;
int rank, info, n100 = 100;
int firsttrial = 1;
double a = 0.0, tol = 1.0e-7, sum, thiscrit, best = DBL_MAX, target, old,
newp, dummy, k0 = pk0;
const arma::vec& y = data.y;
const arma::mat& x = data.x;
double coef[p];
arma::vec coef_vec(coef, p, false, true);
double qraux[p];
double work[2*p];
double res[n];
arma::vec res_vec(res, n, false, true);
double yr[nwhich];
double xr[nwhich * p];
arma::vec yr_vec(yr, nwhich, false, true);
arma::mat xr_mat(xr, nwhich, p, false, true);
double bestcoef[p];
int pivot[p];
arma::uvec which_vec(nwhich);
//int bestone[nwhich];
target = (nn - pp)* (beta);
for(trial = 0; trial < ntrials; trial++) {
R_CheckUserInterrupt();
// get this trial's subset
which_vec = indices.col(trial);
yr_vec = y.elem(which_vec);
xr_mat = x.rows(which_vec);
/* compute fit, find residuals */
F77_CALL(dqrdc2)(xr, &nnew, &nnew, &pp, &tol, &rank, qraux, pivot, work);
if(rank < pp) { sing++; continue; }
F77_CALL(dqrsl)(xr, &nnew, &nnew, &rank, qraux, yr, &dummy, yr, coef,
&dummy, &dummy, &n100, &info);
res_vec = y - x * coef_vec;
/* S estimation */
if(firsttrial) {
for(i = 0; i < nn; i ++) res[i] = fabs(res[i]);
rPsort(res, nn, nn/2);
old = res[nn/2]/0.6745; /* MAD provides the initial scale */
firsttrial = 0;
} else {
/* only find optimal scale if it will be better than
existing best solution */
sum = 0.0;
for(i = 0; i < nn; i ++) sum += chi(res[i], k0 * best);
if(sum > target) continue;
old = best;
}
/* now solve for scale S by re-substitution */
for(iter = 0; iter < 30; iter++) {
/*printf("iter %d, s = %f sum = %f %f\n", iter, old, sum, target);*/
sum = 0.0;
for(i = 0; i < nn; i ++) sum += chi(res[i], k0 * old);
newp = sqrt(sum/target) * old;
if(fabs(sum/target - 1.) < 1e-4) break;
old = newp;
}
thiscrit = newp;
/* first trial might be singular, so use fence */
if(thiscrit < best) {
sum = 0.0;
for(i = 0; i < nn; i ++) sum += chi(res[i], k0 * best);
best = thiscrit;
for(i = 0; i < pp; i++) bestcoef[i] = coef[i];
bestcoef[0] += a;
}
} /* for(trial in 0:ntrials) */
crit = (best < 0.0) ? 0.0 : best;
if(sample) PutRNGstate();
/* lqs_free(); */
// output
arma::vec coef_out(coef_ptr, p, false, true);
arma::vec fitted_out(fitted_ptr, n, false, true);
arma::vec resid_out(resid_ptr, n, false, true);
arma::vec scale_out(scale_ptr, 1, false, true);
for (i = 0; i < p; i++) coef_out[i] = bestcoef[i];
fitted_out = x * coef_out;
resid_out = y - fitted_out;
scale_out = crit;
}
void rlrt1(
double *Ytilde2, const double *D,
const double *S0, const double *S1, double *tau0, double *tau1,
double *rlrt_obs, double *rlrt_sim,
double *gft_obs, double *gft_sim,
int *_n, int *_p, int *_m0, int *_m1, int *_nsim,
double *_tol, double *_b)
{
const int n = *_n, p = *_p;
const int n_minus_p = n - p;
const int m0 = *_m0, m1 = *_m1;
const int k0 = m0 + 1, k1 = m1 + 1;
const int nsim = *_nsim;
const double tol = *_tol;
const double br1 = _b[0], br2 = _b[1], bg1 = _b[2], bg2 = _b[3];
/* work space */
int lwork = k1 * 2 + m1 * 3 + n_minus_p * 4;
double *const work0 = (double *)malloc(lwork * sizeof(double));
if (work0 == 0) {
*rlrt_obs = *gft_obs = 0.0;
return;
}
double *work = work0;
rl_extra extra;
extra.n_minus_p = n_minus_p;
extra.D = D;
extra.w2 = Ytilde2;
double *const restrict Q = work; work += k1;
double *const restrict guess = work; work += k1;
double *const restrict init = work; work += m1;
double *const restrict lower = work; work += m1;
double *const restrict upper = work; work += m1;
double *const restrict Dtau0 = work; work += n_minus_p;
extra.Dtau = work; work += n_minus_p;
extra.w2_Dtau = work; work += n_minus_p;
extra.w2_Dtau2 = work; work += n_minus_p;
for (int h = 0; h < m1; ++h) {
init[h] = 0.0;
lower[h] = 0.0; upper[h] = INFINITY;
}
/* observed test statistics */
double sr, r0, r1, sg, g0, g1;
/* under H0 */
projected_bfgs(init, tau0, m0, &extra, nrl_f, nrl_g, 100, tol,
lower, upper, &r0);
g0 = rss(init, m0, &extra);
for (int h = 0; h < m0; ++h)
tau0[h] = init[h];
/* under H1 */
projected_bfgs(init, tau1, m1, &extra, nrl_f, nrl_g, 100, tol,
lower, upper, &r1);
g1 = rss(init, m1, &extra);
for (int h = 0; h < m1; ++h)
tau1[h] = init[h];
/* difference */
sr = r0 - r1;
*rlrt_obs = sr;
sg = (g0 - g1) / (g1 / n);
*gft_obs = sg;
if (((sr <= br1) || (sr >= br2)) && ((sg <= bg1) || (sg >= bg2))) {
/* p-value is 1 if sr <= br1, or sg <= bg1 */
/* p-value is 0 if sr >= br2, or sg >= bg2 */
free(work0); return;
}
static const char no_trans = 'N', trans = 'T', upper_part = 'U';
static const int inc_one = 1;
static const double zero = 0.0, one = 1.0;
/* Dtau0 <- 1 + c(D[, 1 : m0] %*% tau0) */
F77_CALL(dgemv)(&no_trans, &n_minus_p, &m0, &one, D, &n_minus_p,
tau0, &inc_one, &zero, Dtau0, &inc_one);
for (int j = 0; j < n_minus_p; ++j)
Dtau0[j] += 1.0;
/* simulated test statistics */
GetRNGstate();
double *restrict w2 = Ytilde2;
double sum_w2, z;
for (int i = 0; i < nsim; ++i) {
/* w2 <- Dtau0 * rnorm(n_minus_p) ^ 2; sum_w2 <- sum(w2) */
sum_w2 = 0.0;
for (int j = 0; j < n_minus_p; ++j) {
z = norm_rand();
w2[j] = Dtau0[j] * z * z;
sum_w2 += w2[j];
}
/* Q <- c(t(D) %*% w2, sum_w2) */
F77_CALL(dgemv)(&trans, &n_minus_p, &m1, &one, D,
&n_minus_p, w2, &inc_one, &zero, Q, &inc_one);
Q[m1] = sum_w2;
for (int h = 0; h < m1; ++h)
init[h] = 0.0;
/* under H0 */
z = Q[m0]; Q[m0] = sum_w2;
F77_CALL(dsymv)(&upper_part, &k0, &one, S0, &k0,
Q, &inc_one, &zero, guess, &inc_one);
Q[m0] = z;
z = guess[m0]; if (z < 1e-6) z = 1e-6;
for (int h = 0; h < m0; ++h) {
if (guess[h] > 0.0) guess[h] /= z; else guess[h] = 0.0;
}
projected_bfgs(init, guess, m0, &extra, nrl_f, nrl_g, 100, tol,
lower, upper, &r0);
g0 = rss(init, m0, &extra);
/* under H1 */
F77_CALL(dsymv)(&upper_part, &k1, &one, S1, &k1,
Q, &inc_one, &zero, guess, &inc_one);
z = guess[m1]; if (z < 1e-6) z = 1e-6;
for (int h = 0; h < m1; ++h) {
if (guess[h] > 0.0) guess[h] /= z; else guess[h] = 0.0;
}
projected_bfgs(init, guess, m1, &extra, nrl_f, nrl_g, 100, tol,
lower, upper, &r1);
g1 = rss(init, m1, &extra);
/* simulated test statistics */
sr = r0 - r1;
rlrt_sim[i] = sr;
sg = (g0 - g1) / (g1 / n); if (sg < 0.0) sg = 0.0;
gft_sim[i] = sg;
}
PutRNGstate();
free(work0);
}
void F77_SUB(rndend)(void) { PutRNGstate(); }
/* version when nu = m+1 is an integer
*
* m = interference parameter (m=0 gives no interference)
* p = proportion of chiasmata from no interference process
* L = length of chromosome (in cM)
* Lstar = revised length for simulating numbers of chiasmata, for case of obligate chiasma
* on same scale as L
* nxo = on output, the number of crossovers
* Loc = on output, the locations of the crossovers
* max_nxo = maximum no. crossovers allowed (length of loc)
* obligate_chiasma = 1 if require at least one chiasma (0 otherwise)
*
*/
void simStahl_int(int n_sim, int m, double p, double L,
double Lstar, int *nxo, double **Loc,
int max_nxo, int obligate_chiasma)
{
int i, j, k, n_nichi, n_pts, n_ichi, first, max_pts;
double *ptloc;
double lambda1, lambda2;
/* space for locations of chiasmata and intermediate pts */
max_pts = 2*max_nxo*(m+1);
ptloc = (double *)R_alloc(max_pts, sizeof(double));
GetRNGstate();
if(m==0) { /* looks like a Poisson model */
for(i=0; i< n_sim; i++) {
R_CheckUserInterrupt(); /* check for ^C */
if(obligate_chiasma) {
/* no. chiasmata, required >= 1 */
while((n_ichi = rpois(Lstar/50.0)) == 0);
/* no crossovers by thinning 1/2 */
nxo[i] = rbinom((double)n_ichi, 0.5);
}
else
nxo[i] = rpois(Lstar/100.0);
if(nxo[i] > max_nxo)
error("Exceeded maximum number of crossovers.");
for(j=0; j < nxo[i]; j++)
Loc[i][j] = runif(0.0, L);
}
}
else {
lambda1 = Lstar/50.0 * (m+1) * (1.0 - p);
lambda2 = Lstar/50.0 * p;
for(i=0; i< n_sim; i++) {
while(1) {
R_CheckUserInterrupt(); /* check for ^C */
/* simulate no. chiasmata + intermediate pts from interference process */
n_pts = rpois(lambda1);
/* simulate location of the first */
first = random_int(0, m);
if(first > n_pts) n_ichi = 0;
else n_ichi = n_pts/(m+1) + (int)(first < (n_pts % (m+1)));
/* simulate no. chiamata from the no-interference model */
n_nichi = rpois(lambda2);
if(!obligate_chiasma || n_ichi + n_nichi > 0) break;
}
/* simulate no. chiasmta + intermediate points */
/* first check if we have space */
if(n_pts > max_pts) {
ptloc = (double *)S_realloc((char *)ptloc, n_pts*2, max_pts, sizeof(double));
max_pts = n_pts*2;
}
for(j=0; j<n_pts; j++)
ptloc[j] = runif(0.0, L);
/* sort them */
R_rsort(ptloc, n_pts);
/* take every (m+1)st */
for(j=first, k=0; j<n_pts; j += (m+1), k++)
ptloc[k] = ptloc[j];
n_ichi = k;
/* simulate chiasmata from no-interference model */
for(j=0; j<n_nichi; j++)
ptloc[n_ichi + j] = runif(0.0, L);
/* sort the combined ones */
R_rsort(ptloc, n_ichi + n_nichi);
/* thin by 1/2 */
nxo[i] = 0;
for(j=0; j<n_ichi + n_nichi; j++) {
if(unif_rand() < 0.5) {
Loc[i][nxo[i]] = ptloc[j];
(nxo[i])++;
}
}
} /* loop over no. simulations */
} /* m > 0 */
PutRNGstate();
}
/* conditional Monte Carlo simulation for discrete tests. */
SEXP cmcarlo(SEXP x, SEXP y, SEXP z, SEXP lx, SEXP ly, SEXP lz,
SEXP length, SEXP samples, SEXP test, SEXP alpha) {
double *fact = NULL, *res = NULL, observed = 0;
int **n = NULL, **ncolt = NULL, **nrowt = NULL, *ncond = NULL, *workspace = NULL;
int *num = INTEGER(length), *B = INTEGER(samples);
int *nr = INTEGER(lx), *nc = INTEGER(ly), *nl = INTEGER(lz);
int *xx = INTEGER(x), *yy = INTEGER(y), *zz = INTEGER(z);
int i = 0, j = 0, k = 0, npermuts = 0, enough = ceil(NUM(alpha) * (*B)) + 1;
SEXP result;
/* allocate and initialize the result */
PROTECT(result = allocVector(REALSXP, 3));
res = REAL(result);
res[0] = res[1] = res[2] = 0; // initial test score / p-value / nb permutations
/* allocate and compute the factorials needed by rcont2. */
allocfact(*num);
/* allocate and initialize the workspace for rcont2. */
workspace = alloc1dcont(*nc);
/* initialize the contingency table. */
n = alloc2dcont(*nl, (*nr) * (*nc));
/* initialize the marginal frequencies. */
nrowt = alloc2dcont(*nl, *nr);
ncolt = alloc2dcont(*nl, *nc);
ncond = alloc1dcont(*nl);
/* compute the joint frequency of x and y. */
for (k = 0; k < *num; k++)
n[zz[k] - 1][CMC(xx[k] - 1, yy[k] - 1, *nr)]++;
/* compute the marginals. */
for (i = 0; i < *nr; i++)
for (j = 0; j < *nc; j++)
for (k = 0; k < *nl; k++) {
nrowt[k][i] += n[k][CMC(i, j, *nr)];
ncolt[k][j] += n[k][CMC(i, j, *nr)];
ncond[k] += n[k][CMC(i, j, *nr)];
}/*FOR*/
/* initialize the random number generator. */
GetRNGstate();
/* pick up the observed value of the test statistic, then generate a set of
random contingency tables (given row and column totals) and check how many
tests are greater than the original one.*/
switch(INT(test)) {
case MUTUAL_INFORMATION:
observed = _cmi(n, nrowt, ncolt, ncond, nr, nc, nl);
for (j = 0; j < *B; j++) {
for (k = 0; k < *nl; k++)
rcont2(nr, nc, nrowt[k], ncolt[k], &(ncond[k]), fact, workspace, n[k]);
if (_cmi(n, nrowt, ncolt, ncond, nr, nc, nl) > observed) {
sequential_counter_check(res[1]);
}/*THEN*/
npermuts++;
}/*FOR*/
observed = 2 * observed;
break;
case PEARSON_X2:
observed = _cx2(n, nrowt, ncolt, ncond, nr, nc, nl);
for (j = 0; j < *B; j++) {
for (k = 0; k < *nl; k++)
rcont2(nr, nc, nrowt[k], ncolt[k], &(ncond[k]), fact, workspace, n[k]);
if (_cx2(n, nrowt, ncolt, ncond, nr, nc, nl) > observed) {
sequential_counter_check(res[1]);
}/*THEN*/
npermuts++;
}/*FOR*/
break;
}/*SWITCH*/
PutRNGstate();
/* save the observed value of the statistic, the corresponding
p-value, and the number of permutations performed. */
res[0] = observed;
res[1] /= *B;
res[2] = npermuts;
UNPROTECT(1);
return result;
}/*CMCARLO*/
SEXP do_init_state (SEXP object, SEXP params, SEXP t0, SEXP nsim, SEXP gnsi)
{
int nprotect = 0;
SEXP Pnames, Snames;
SEXP x = R_NilValue;
int *dim;
int npar, nrep, nvar, ns;
int definit;
int xdim[2];
const char *dimnms[2] = {"variable","rep"};
ns = *(INTEGER(AS_INTEGER(nsim)));
PROTECT(params = as_matrix(params)); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
dim = INTEGER(GET_DIM(params));
npar = dim[0]; nrep = dim[1];
if (ns % nrep != 0)
errorcall(R_NilValue,"in 'init.state': number of desired state-vectors 'nsim' is not a multiple of ncol('params')");
definit = *(INTEGER(GET_SLOT(object,install("default.init"))));
if (definit) { // default initializer
SEXP fcall, pat, repl, val, ivpnames, statenames;
int *pidx, j, k;
double *xp, *pp;
PROTECT(pat = NEW_CHARACTER(1)); nprotect++;
SET_STRING_ELT(pat,0,mkChar("\\.0$"));
PROTECT(repl = NEW_CHARACTER(1)); nprotect++;
SET_STRING_ELT(repl,0,mkChar(""));
PROTECT(val = NEW_LOGICAL(1)); nprotect++;
*(INTEGER(val)) = 1;
// extract names of IVPs
PROTECT(fcall = LCONS(val,R_NilValue)); nprotect++;
SET_TAG(fcall,install("value"));
PROTECT(fcall = LCONS(Pnames,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(pat,fcall)); nprotect++;
SET_TAG(fcall,install("pattern"));
PROTECT(fcall = LCONS(install("grep"),fcall)); nprotect++;
PROTECT(ivpnames = eval(fcall,R_BaseEnv)); nprotect++;
nvar = LENGTH(ivpnames);
if (nvar < 1) {
errorcall(R_NilValue,"in default 'initializer': there are no parameters with suffix '.0'. See '?pomp'.");
}
pidx = INTEGER(PROTECT(match(Pnames,ivpnames,0))); nprotect++;
for (k = 0; k < nvar; k++) pidx[k]--;
// construct names of state variables
PROTECT(fcall = LCONS(ivpnames,R_NilValue)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(repl,fcall)); nprotect++;
SET_TAG(fcall,install("replacement"));
PROTECT(fcall = LCONS(pat,fcall)); nprotect++;
SET_TAG(fcall,install("pattern"));
PROTECT(fcall = LCONS(install("sub"),fcall)); nprotect++;
PROTECT(statenames = eval(fcall,R_BaseEnv)); nprotect++;
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,statenames,2);
fixdimnames(x,dimnms,2);
for (j = 0, xp = REAL(x); j < ns; j++) {
pp = REAL(params) + npar*(j%nrep);
for (k = 0; k < nvar; k++, xp++)
*xp = pp[pidx[k]];
}
} else { // user-supplied initializer
SEXP pompfun, fcall, fn, tcovar, covar, covars = R_NilValue;
pompfunmode mode = undef;
double *cp = NULL;
// extract the initializer function and its environment
PROTECT(pompfun = GET_SLOT(object,install("initializer"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
// extract covariates and interpolate
PROTECT(tcovar = GET_SLOT(object,install("tcovar"))); nprotect++;
if (LENGTH(tcovar) > 0) { // do table lookup
PROTECT(covar = GET_SLOT(object,install("covar"))); nprotect++;
PROTECT(covars = lookup_in_table(tcovar,covar,t0)); nprotect++;
cp = REAL(covars);
}
// extract userdata
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
switch (mode) {
case Rfun: // use R function
{
SEXP par, rho, x1, x2;
double *p, *pp, *xp, *xt;
int j, *midx;
// extract covariates and interpolate
if (LENGTH(tcovar) > 0) { // add covars to call
PROTECT(fcall = LCONS(covars,fcall)); nprotect++;
SET_TAG(fcall,install("covars"));
}
// parameter vector
PROTECT(par = NEW_NUMERIC(npar)); nprotect++;
SET_NAMES(par,Pnames);
pp = REAL(par);
// finish constructing the call
PROTECT(fcall = LCONS(t0,fcall)); nprotect++;
SET_TAG(fcall,install("t0"));
PROTECT(fcall = LCONS(par,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// evaluation environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
p = REAL(params);
memcpy(pp,p,npar*sizeof(double)); // copy the parameters
PROTECT(x1 = eval(fcall,rho)); nprotect++; // do the call
PROTECT(Snames = GET_NAMES(x1)); nprotect++;
if (!IS_NUMERIC(x1) || isNull(Snames)) {
UNPROTECT(nprotect);
errorcall(R_NilValue,"in 'init.state': user 'initializer' must return a named numeric vector");
}
nvar = LENGTH(x1);
xp = REAL(x1);
midx = INTEGER(PROTECT(match(Pnames,Snames,0))); nprotect++;
for (j = 0; j < nvar; j++) {
if (midx[j]!=0) {
UNPROTECT(nprotect);
errorcall(R_NilValue,"in 'init.state': a state variable and a parameter share a single name: '%s'",CHARACTER_DATA(STRING_ELT(Snames,j)));
}
}
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,Snames,2);
fixdimnames(x,dimnms,2);
xt = REAL(x);
memcpy(xt,xp,nvar*sizeof(double));
for (j = 1, xt += nvar; j < ns; j++, xt += nvar) {
memcpy(pp,p+npar*(j%nrep),npar*sizeof(double));
PROTECT(x2 = eval(fcall,rho));
xp = REAL(x2);
if (LENGTH(x2)!=nvar)
errorcall(R_NilValue,"in 'init.state': user initializer returns vectors of non-uniform length");
memcpy(xt,xp,nvar*sizeof(double));
UNPROTECT(1);
}
}
break;
case native: // use native routine
{
SEXP Cnames;
int *sidx, *pidx, *cidx;
double *xt, *ps, time;
pomp_initializer *ff = NULL;
int j;
PROTECT(Snames = GET_SLOT(pompfun,install("statenames"))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++;
// construct state, parameter, covariate, observable indices
sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++;
pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++;
cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++;
// address of native routine
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
nvar = LENGTH(Snames);
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,Snames,2);
fixdimnames(x,dimnms,2);
set_pomp_userdata(fcall);
GetRNGstate();
time = *(REAL(t0));
// loop over replicates
for (j = 0, xt = REAL(x), ps = REAL(params); j < ns; j++, xt += nvar)
(*ff)(xt,ps+npar*(j%nrep),time,sidx,pidx,cidx,cp);
PutRNGstate();
unset_pomp_userdata();
}
break;
default:
errorcall(R_NilValue,"in 'init.state': unrecognized 'mode'"); // # nocov
break;
}
}
UNPROTECT(nprotect);
return x;
}
