double dtnorm_std(const double lower_bound)
{
double y;
if (lower_bound < 0.0)
{
do {
y = norm_rand();
} while (y <= lower_bound);
return y;
}
else if (lower_bound < 0.75)
{
do {
y = fabs(norm_rand());
} while (y <= lower_bound);
return y;
}
else
{
do {
y = exp_rand();
} while (exp_rand() * lower_bound * lower_bound <= 0.5 * y * y);
return y / lower_bound + lower_bound;
}
}
/* Sample from the MVN dist */
void rMVN(
double *Sample, /* Vector for the sample */
double *mean, /* The vector of means */
double **Var, /* The matrix Variance */
int size) /* The dimension */
{
int j,k;
double **Model = doubleMatrix(size+1, size+1);
double cond_mean;
/* draw from mult. normal using SWP */
for(j=1;j<=size;j++){
for(k=1;k<=size;k++)
Model[j][k]=Var[j-1][k-1];
Model[0][j]=mean[j-1];
Model[j][0]=mean[j-1];
}
Model[0][0]=-1;
Sample[0]=(double)norm_rand()*sqrt(Model[1][1])+Model[0][1];
for(j=2;j<=size;j++){
SWP(Model,j-1,size+1);
cond_mean=Model[j][0];
for(k=1;k<j;k++) cond_mean+=Sample[k-1]*Model[j][k];
Sample[j-1]=(double)norm_rand()*sqrt(Model[j][j])+cond_mean;
}
FreeMatrix(Model,size+1);
}
// draw from MVN -- adapted from R package MNP
void rMVN(
std::vector<double>& Sample,
std::vector<double>& mean,
std::vector<std::vector<double> >& Var,
size_t size)
{
GetRNGstate();
std::vector<std::vector<double> > Model;
Model.resize(size +1);
for(size_t j=0; j<= size; j++){
Model[j].resize(size + 1);
}
double cond_mean;
/* draw from mult. normal using SWP */
for(size_t j=1;j<=size;j++){
for(size_t k=1;k<=size;k++) {
Model[j][k]=Var[j-1][k-1];
}
Model[0][j]=mean[j-1];
Model[j][0]=mean[j-1];
}
Model[0][0]=-1;
Sample[0]=(double)norm_rand()*sqrt(Model[1][1])+Model[0][1];
for(size_t j=2;j<=size;j++){
SWP(Model,j-1,size+1);
cond_mean=Model[j][0];
for(size_t k=1;k<j;k++) cond_mean+=Sample[k-1]*Model[j][k];
Sample[j-1]=(double)norm_rand()*sqrt(Model[j][j])+cond_mean;
}
PutRNGstate();
}
// ======================================================================
// norm_rs(a, b)
// generates a sample from a N(0,1) RV restricted to be in the interval
// (a,b) via rejection sampling.
// This function should be called by rnorm_truncated (where Get/PutRNGstate
// are invoked)
// ======================================================================
double
norm_rs(double a, double b)
{
double x;
x = norm_rand();
while( (x < a) || (x > b) ) x = norm_rand();
return x;
}
// ======================================================================
// half_norm_rs(a, b)
// generates a sample from a N(0,1) RV restricted to the interval
// (a,b) (with a > 0) using half normal rejection sampling.
// This function should be called by rnorm_truncated (where Get/PutRNGstate
// are invoked)
// ======================================================================
double
half_norm_rs(double a, double b)
{
double x;
//assert(a >= 0); // check it
x = fabs(norm_rand());
while( (x<a) || (x>b) ) x = fabs(norm_rand());
return x;
}
// ======================================================================
// norm_rs(a, b)
// generates a sample from a N(0,1) RV restricted to be in the interval
// (a,b) via rejection sampling.
// ======================================================================
double
norm_rs(double a, double b)
{
double x;
GetRNGstate();
x = norm_rand();
while( (x < a) || (x > b) ){
x = norm_rand();
}
PutRNGstate();
return x;
}
double rt(double df, JRNG *rng)
{
if (ISNAN(df) || df <= 0.0) ML_ERR_return_NAN;
if(!R_FINITE(df))
return norm_rand(rng);
else {
/* Some compilers (including MW6) evaluated this from right to left
return norm_rand(rng) / sqrt(rchisq(df, rng) / df); */
double num = norm_rand(rng);
return num / sqrt(rchisq(df, rng) / df);
}
}
int
main(int argc, char** argv)
{
/* something to force the library to be included */
qnorm(0.7, 0.0, 1.0, 0, 0);
printf("*** loaded '%s'\n", argv[0]);
set_seed(123, 456);
N01_kind = AHRENS_DIETER;
printf("one normal %f\n", norm_rand());
set_seed(123, 456);
N01_kind = BOX_MULLER;
printf("normal via BM %f\n", norm_rand());
return 0;
}
double sTruncNorm(
double bd, /* bound */
double mu,
double var,
int lower /* 1 = x > bd, 0 = x < bd */
) {
double z, logb, lambda, u;
double sigma = sqrt(var);
double stbd = (bd - mu)/sigma;
if (lower == 0) {
stbd = (mu - bd)/sigma;
}
if (stbd > 0) {
lambda = 0.5*(stbd + sqrt(stbd*stbd + 4));
logb = 0.5*(lambda*lambda-2*lambda*stbd);
do {
z = rexp(1/lambda);
/* Rprintf("%5g\n", exp(-0.5*(z+stbd)*(z+stbd)+lambda*z-logb)); */
} while (unif_rand() > exp(-0.5*(z+stbd)*(z+stbd)+lambda*z-logb));
} else {
do z = norm_rand();
while(z < stbd);
}
if (lower == 1) {
return(z*sigma + mu);
} else {
return(-z*sigma + mu);
}
}
static void genptry(int n, double *p, double *ptry, double scale, void *ex)
{
SEXP s, x;
int i;
OptStruct OS = (OptStruct) ex;
PROTECT_INDEX ipx;
if (!isNull(OS->R_gcall)) {
/* user defined generation of candidate point */
PROTECT(x = allocVector(REALSXP, n));
for (i = 0; i < n; i++) {
if (!R_FINITE(p[i]))
error(_("non-finite value supplied by 'optim'"));
REAL(x)[i] = p[i] * (OS->parscale[i]);
}
SETCADR(OS->R_gcall, x);
PROTECT_WITH_INDEX(s = eval(OS->R_gcall, OS->R_env), &ipx);
REPROTECT(s = coerceVector(s, REALSXP), ipx);
if(LENGTH(s) != n)
error(_("candidate point in 'optim' evaluated to length %d not %d"),
LENGTH(s), n);
for (i = 0; i < n; i++)
ptry[i] = REAL(s)[i] / (OS->parscale[i]);
UNPROTECT(2);
}
else { /* default Gaussian Markov kernel */
for (i = 0; i < n; i++)
ptry[i] = p[i] + scale * norm_rand(); /* new candidate point */
}
}
void simbc_qtl(int n_progeny, int n_chromosomes, int *n_markers,
double *recfrac, int *genotypes,
double *phenotypes, int n_qtl, int *qtl_chr,
int *mar_to_left, double *recfrac_to_left,
double *effect, double sigma)
{
int i, k;
double r, theta_left, theta_right;
double r_r, r_nr;
/* simulate marker data */
simbc_mar(n_progeny, n_chromosomes, n_markers,
recfrac, genotypes);
/* simulate environmental variation */
for(k=0; k< n_progeny; k++)
phenotypes[k] = norm_rand() * sigma;
for(i=0; i < n_qtl; i++) {
/* rec. frac to left and right of QTL */
theta_left = recfrac_to_left[i];
theta_right = 0.5*(1.0-(1.0-2.0*recfrac[mar_to_left[i] - qtl_chr[i] - 1])/
(1.0-2.0*theta_left));
/* get cond'l prob of QTL genotype given marker genotypes */
r_r = theta_left * (1.0-theta_right);
r_r = r_r / (r_r + theta_right * (1.0-theta_left));
r_nr = theta_left * theta_right;
r_nr = r_nr / (r_nr + (1.0 - theta_left)*(1.0-theta_right));
/* simulate QTL genotypes */
r = unif_rand();
for(k=0; k< n_progeny; k++) {
if(genotypes[k + mar_to_left[i] * n_progeny]) {
if(genotypes[k + (mar_to_left[i]-1) * n_progeny]) {
/* both markers are 1 */
if(r > r_nr) /* non recombinant : QTL = 1 */
phenotypes[k] += effect[i];
}
else {
/* mar to left is 1; mar to right is 0 */
if(r > r_r) /* recomb in right interval: QTL = 1 */
phenotypes[k] += effect[i];
}
}
else {
if(genotypes[k + (mar_to_left[i]-1) * n_progeny]) {
/* mar to left is 0; mar to right is 1 */
if(r < r_r) /* recomb in left interval: QTL = 1 */
phenotypes[k] += effect[i];
}
else {
/* both markers are 0 */
if(r < r_nr) /* double recombinant : QTL = 1 */
phenotypes[k] += effect[i];
}
}
}
}
}
static void propose(double *x, double *proposal, double *a, double *b, int d,
int n, double *z, double *smax_out, double *smin_out, double *u_out)
{
for (int i = 0; i < d; i++) {
z[i] = norm_rand();
}
double smax = R_PosInf;
double smin = R_NegInf;
for (int i = 0; i < n; i++) {
double ax = 0.0;
double az = 0.0;
for (int j = 0; j < d; j++) {
ax += a[i + j * n] * x[j];
az += a[i + j * n] * z[j];
}
double bound = (b[i] - ax) / az;
if (az > 0 && bound < smax)
smax = bound;
if (az < 0 && bound > smin)
smin = bound;
}
double u = unif_rand();
for (int i = 0; i < d; i++)
proposal[i] = x[i] + (u * smin + (1.0 - u) * smax) * z[i];
*smax_out = smax;
*smin_out = smin;
*u_out = u;
}
void sim_null(int n_ind, int n_chr, int *n_mar, int tot_mar,
double *recfrac, int n_cim, int *cim_steps,
int n_sim, double *maxlod, int *iwork, double *dwork)
{
int i, j, k, r, err;
double *phenotypes, *xpx, *lod, *rss;
int *index, *genotypes;
/* set up workspace */
genotypes = iwork; /* length = n_ind * tot_mar */
index = genotypes + n_ind * tot_mar; /* length = tot_mar */
phenotypes = dwork; /* length = n_ind */
xpx = phenotypes + n_ind; /* length = (tot_mar+2)^2 */
lod = xpx+(tot_mar+2)*(tot_mar+2); /* length = tot_mar */
rss = lod + tot_mar; /* length = tot_mar + 1 */
/* set up index */
for(i=0; i<tot_mar; i++) index[i] = i+1;
for(i=0; i<n_sim; i++) {
/* simulate genotype data */
simbc_mar(n_ind, n_chr, n_mar, recfrac, genotypes);
/* simulate phenotype data */
for(j=0; j<n_ind; j++)
phenotypes[j] = norm_rand();
/* calculate X'X matrix */
calc_xpx(n_ind, tot_mar+2, genotypes, phenotypes, xpx);
/* perform ANOVA */
anal_anova(n_ind, tot_mar, xpx, lod);
/* find maximum */
maxlod[i] = lod[0];
for(j=1; j<tot_mar; j++)
if(maxlod[i] < lod[j])
maxlod[i] = lod[j];
/* perform forward selection */
forward(tot_mar, xpx, cim_steps[0], index, rss);
for(j=0, r=n_sim; j<n_cim; j++, r += n_sim) {
/* unsweep columns */
if(j>0) sweep(xpx, tot_mar+2, index+cim_steps[j],
cim_steps[j-1]-cim_steps[j], &err);
/* perform CIM */
anal_cim(n_ind, tot_mar, xpx, lod, index, cim_steps[j], 1);
maxlod[i+r] = lod[0];
for(k=1; k<tot_mar; k++)
if(maxlod[i+r] < lod[k])
maxlod[i+r] = lod[k];
}
}
}
double rnorm(double mu, double sigma)
{
if (ISNAN(mu) || !R_FINITE(sigma) || sigma < 0.)
ML_ERR_return_NAN;
if (sigma == 0. || !R_FINITE(mu))
return mu; /* includes mu = +/- Inf with finite sigma */
else
return mu + sigma * norm_rand();
}
void rWish(
double **Sample, /* The matrix with to hold the sample */
double **S, /* The parameter */
int df, /* the degrees of freedom */
int size) /* The dimension */
{
int i,j,k;
double *V = doubleArray(size);
double **B = doubleMatrix(size, size);
double **C = doubleMatrix(size, size);
double **N = doubleMatrix(size, size);
double **mtemp = doubleMatrix(size, size);
for(i=0;i<size;i++) {
V[i]=rchisq((double) df-i-1);
B[i][i]=V[i];
for(j=(i+1);j<size;j++)
N[i][j]=norm_rand();
}
for(i=0;i<size;i++) {
for(j=i;j<size;j++) {
Sample[i][j]=0;
Sample[j][i]=0;
mtemp[i][j]=0;
mtemp[j][i]=0;
if(i==j) {
if(i>0)
for(k=0;k<j;k++)
B[j][j]+=N[k][j]*N[k][j];
}
else {
B[i][j]=N[i][j]*sqrt(V[i]);
if(i>0)
for(k=0;k<i;k++)
B[i][j]+=N[k][i]*N[k][j];
}
B[j][i]=B[i][j];
}
}
dcholdc(S, size, C);
for(i=0;i<size;i++)
for(j=0;j<size;j++)
for(k=0;k<size;k++)
mtemp[i][j]+=C[i][k]*B[k][j];
for(i=0;i<size;i++)
for(j=0;j<size;j++)
for(k=0;k<size;k++)
Sample[i][j]+=mtemp[i][k]*C[j][k];
free(V);
FreeMatrix(B, size);
FreeMatrix(C, size);
FreeMatrix(N, size);
FreeMatrix(mtemp, size);
}
void rWish(std::vector<std::vector<double> >& Sample, /* The matrix with to hold the sample */
std::vector<std::vector<double> >& S, /* The parameter */
int df, /* the degrees of freedom */
int size) /* The dimension */
{
GetRNGstate();
int i,j,k;
double* V = new double[(int)size];
std::vector<std::vector<double> > B, C, N, mtemp;
B.resize(size); C.resize(size); N.resize(size); mtemp.resize(size);
for (j = 0; j < size; j++){
B[j].resize(size); C[j].resize(size); N[j].resize(size); mtemp[j].resize(size);
}
for(i=0;i<size;i++) {
V[i]=rchisq((double) df-i-1);
B[i][i]=V[i];
for(j=(i+1);j<size;j++)
N[i][j]=norm_rand();
}
for(i=0;i<size;i++) {
for(j=i;j<size;j++) {
Sample[i][j]=0;
Sample[j][i]=0;
mtemp[i][j]=0;
mtemp[j][i]=0;
if(i==j) {
if(i>0)
for(k=0;k<j;k++)
B[j][j]+=N[k][j]*N[k][j];
}
else {
B[i][j]=N[i][j]*sqrt(V[i]);
if(i>0)
for(k=0;k<i;k++)
B[i][j]+=N[k][i]*N[k][j];
}
B[j][i]=B[i][j];
}
}
dcholdc(S, size, C);
for(i=0;i<size;i++)
for(j=0;j<size;j++)
for(k=0;k<size;k++)
mtemp[i][j]+=C[i][k]*B[k][j];
for(i=0;i<size;i++)
for(j=0;j<size;j++)
for(k=0;k<size;k++)
Sample[i][j]+=mtemp[i][k]*C[j][k];
PutRNGstate();
}
void normal_fill1 (int *fn, int *fp,double *datavals, double delta, double *basevals)
{
int i, j,n,p;
n= *fn; p=*fp;
for (i=0;i<n; i++)
{ for (j=0; j<p; j++)
datavals[j*n+i] = basevals[j*n+i]+delta*norm_rand();
}
}
/* Sample from a univariate truncated Normal distribution
(truncated both from above and below): choose either inverse cdf
method or rejection sampling method. For rejection sampling,
if the range is too far from mu, it uses standard rejection
sampling algorithm with exponential envelope function. */
double TruncNorm(
double lb, /* lower bound */
double ub, /* upper bound */
double mu, /* mean */
double var, /* variance */
int invcdf /* use inverse cdf method? */
) {
double z;
double sigma = sqrt(var);
double stlb = (lb-mu)/sigma; /* standardized lower bound */
double stub = (ub-mu)/sigma; /* standardized upper bound */
if(stlb > stub)
error("TruncNorm: lower bound is greater than upper bound\n");
if(stlb == stub) {
warning("TruncNorm: lower bound is equal to upper bound\n");
return(stlb*sigma + mu);
}
if (invcdf) { /* inverse cdf method */
z = qnorm(runif(pnorm(stlb, 0, 1, 1, 0), pnorm(stub, 0, 1, 1, 0)),
0, 1, 1, 0);
}
else { /* rejection sampling method */
double tol=2.0;
double temp, M, u, exp_par;
int flag=0; /* 1 if stlb, stub <-tol */
if(stub<=-tol){
flag=1;
temp=stub;
stub=-stlb;
stlb=-temp;
}
if(stlb>=tol){
exp_par=stlb;
while(pexp(stub,1/exp_par,1,0) - pexp(stlb,1/exp_par,1,0) < 0.000001)
exp_par/=2.0;
if(dnorm(stlb,0,1,1) - dexp(stlb,1/exp_par,1) >=
dnorm(stub,0,1,1) - dexp(stub,1/exp_par,1))
M=exp(dnorm(stlb,0,1,1) - dexp(stlb,1/exp_par,1));
else
M=exp(dnorm(stub,0,1,1) - dexp(stub,1/exp_par,1));
do{
u=unif_rand();
z=-log(1-u*(pexp(stub,1/exp_par,1,0)-pexp(stlb,1/exp_par,1,0))
-pexp(stlb,1/exp_par,1,0))/exp_par;
}while(unif_rand() > exp(dnorm(z,0,1,1)-dexp(z,1/exp_par,1))/M );
if(flag==1) z=-z;
}
else{
do z=norm_rand();
while( z<stlb || z>stub );
}
}
return(z*sigma + mu);
}
void confBandBasePredict (double *delta, int *nObs, int *nt, int *n,
double *se, double *mpt, int *nSims){
int nRowDelta = *nObs * *nt;
// nColDelta = *n
// se is a vector of length nRowDelta
// mpt is a vector of length *n
// pt is a vector of length nRowDelta
int i,j,k; // dummy variables, counters
// The next line does: double g[*n]; // vector of IID random normals
double *g = (double *)malloc(*n * sizeof(double));
// The next line does: double pt[nRowDelta];
double *pt = (double *)malloc(nRowDelta * sizeof(double));
double pt1, pt2; // temporary variables used while calculating maxima
// Some parameters to give to DGEMV in the BLAS library
char trans = 'n';
double alpha = 1.0;
double beta = 0.0;
int incx = 1;
int incy = 1;
double norm_rand();
void GetRNGstate(),PutRNGstate();
GetRNGstate();
for(i = 0; i < *nSims; i++){ // Number of draws
// First generate IID random normal vector of length *n
for(j = 0; j < *n; j++){
g[j] = norm_rand();
}
// Matrix multiplication:
// pt := delta %*% g
F77_CALL(dgemv)(&trans, &nRowDelta, n, &alpha,
delta, &nRowDelta, g, &incx, &beta, pt, &incy);
for(k = 0; k < *nObs; k++){
pt1 = -1.0e99; // initially set to -INF
for(j = 0; j < *nt; j++){
pt2 = fabs(pt[k * *nt + j])/se[k * *nt + j];
if(pt1 < pt2){
pt1 = pt2;
}
}
mpt[i * *nObs + k] = pt1;
}
}
PutRNGstate();
// prevent memory leaks by unallocating memory allocated by malloc
free(g);
free(pt);
}
/* dplR: Samples an AR1 process with time scale 'tau'. The samples
* are taken at 'np' locations separated by times in 'difft', a vector
* of length 'np - 1'.
*/
SEXP makear1(SEXP difft, SEXP np, SEXP tau) {
double dt, tau_val, np_val;
double *difft_data, *red_data;
SEXP red;
size_t i;
tau_val = *REAL(tau);
np_val = (size_t) *REAL(np);
difft_data = REAL(difft);
PROTECT(red = allocVector(REALSXP, np_val));
red_data = REAL(red);
GetRNGstate();
/* set up AR(1) time series */
red_data[0] = norm_rand();
for (i = 1; i < np_val; i++) {
dt = difft_data[i - 1];
red_data[i] = exp(-dt / tau_val) * red_data[i-1] +
sqrt(1.0 - exp(-2.0 * dt / tau_val)) * norm_rand();
}
PutRNGstate();
UNPROTECT(1);
return(red);
}
/**
* Update the fixed effects and the orthogonal random effects in an MCMC sample
* from an mer object.
*
* @param x an mer object
* @param sigma current standard deviation of the per-observation
* noise terms.
* @param fvals pointer to memory in which to store the updated beta
* @param rvals pointer to memory in which to store the updated b (may
* be (double*)NULL)
*/
static void MCMC_beta_u(SEXP x, double sigma, double *fvals, double *rvals)
{
int *dims = DIMS_SLOT(x);
int i1 = 1, p = dims[p_POS], q = dims[q_POS];
double *V = V_SLOT(x), *fixef = FIXEF_SLOT(x), *muEta = MUETA_SLOT(x),
*u = U_SLOT(x), mone[] = {-1,0}, one[] = {1,0};
CHM_FR L = L_SLOT(x);
double *del1 = Calloc(q, double), *del2 = Alloca(p, double);
CHM_DN sol, rhs = N_AS_CHM_DN(del1, q, 1);
R_CheckStack();
if (V || muEta) {
error(_("Update not yet written"));
} else { /* Linear mixed model */
update_L(x);
update_RX(x);
lmm_update_fixef_u(x);
/* Update beta */
for (int j = 0; j < p; j++) del2[j] = sigma * norm_rand();
F77_CALL(dtrsv)("U", "N", "N", &p, RX_SLOT(x), &p, del2, &i1);
for (int j = 0; j < p; j++) fixef[j] += del2[j];
/* Update u */
for (int j = 0; j < q; j++) del1[j] = sigma * norm_rand();
F77_CALL(dgemv)("N", &q, &p, mone, RZX_SLOT(x), &q,
del2, &i1, one, del1, &i1);
sol = M_cholmod_solve(CHOLMOD_Lt, L, rhs, &c);
for (int j = 0; j < q; j++) u[j] += ((double*)(sol->x))[j];
M_cholmod_free_dense(&sol, &c);
update_mu(x); /* and parts of the deviance slot */
}
Memcpy(fvals, fixef, p);
if (rvals) {
update_ranef(x);
Memcpy(rvals, RANEF_SLOT(x), q);
}
Free(del1);
}
/* Written by William Constantine */
mutil_errcode mutil_rand_normal( void *rand_ptr, double *num_out )
{
MUTIL_TRACE("Start mutil_rand_normal()");
/* avoid lint warning */
(void) rand_ptr;
if( !num_out ) {
MUTIL_ERROR( "NULL pointer for output" );
return MUTIL_ERR_NULL_POINTER;
}
*num_out = norm_rand();
MUTIL_TRACE("Done with mutil_rand_normal()");
return MUTIL_ERR_OK;
}
void dcat_randomsample(double *x, unsigned int length, double* par, unsigned int npar, NMATH_STATE *ms)
{
double sump = 0.0;
unsigned int i = 0;
double p, prob;
for( i = 0 ; i < npar ; i++ ) {
prob = par[i];
sump += prob;
}
p = sump * norm_rand(ms);
for( i = npar-1 ; i > 0 ; i-- ) {
prob = par[i];
sump -= prob;
if( sump <= p ) break;
}
x[0] = (double)i;
}
void direct(int *n, int *nSite, int *grid, int *covmod, double *coord, int *dim,
double *nugget, double *sill, double *range, double *smooth,
double *ans){
int neffSite = *nSite, lagi = 1, lagj = 1;
if (*grid){
neffSite = R_pow_di(neffSite, *dim);
lagi = neffSite;
}
else
lagj = *n;
double *covmat = malloc(neffSite * 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");
/* Simulation part */
GetRNGstate();
for (int i=0;i<*n;i++){
for (int j=0;j<neffSite;j++)
ans[j * lagj + i * lagi] = norm_rand();
F77_CALL(dtrmv)("U", "T", "N", &neffSite, covmat, &neffSite,
ans + i * lagi, &lagj);
}
PutRNGstate();
free(covmat);
return;
}
/**
* Simulate the Cholesky factor of a standardized Wishart variate with
* dimension p and nu degrees of freedom.
*
* @param nu degrees of freedom
* @param p dimension of the Wishart distribution
* @param upper if 0 the result is lower triangular, otherwise upper
triangular
* @param ans array of size p * p to hold the result
*
* @return ans
*/
static double
*std_rWishart_factor(double nu, int p, int upper, double ans[])
{
int pp1 = p + 1;
if (nu < (double) p || p <= 0)
error(_("inconsistent degrees of freedom and dimension"));
memset(ans, 0, p * p * sizeof(double));
for (int j = 0; j < p; j++) { /* jth column */
ans[j * pp1] = sqrt(rchisq(nu - (double) j));
for (int i = 0; i < j; i++) {
int uind = i + j * p, /* upper triangle index */
lind = j + i * p; /* lower triangle index */
ans[(upper ? uind : lind)] = norm_rand();
ans[(upper ? lind : uind)] = 0;
}
}
return ans;
}
void Node::currentFits(MuS* mod,int nTrain,double** xTrain,double* yTrain,int nTest,double** xTest,double* w, double **fits)
{
double ybar,postmu,postsd,b,a; //posterior of mu in a bottom node
double nodeMu; //draw of mu, for a bottom node
voidP* botvec = GetBotArray(); //bottom nodes
int* indPartTest;
if(nTest) indPartTest = GetIndPart(nTest,xTest); //partition of test x re bottom nodes
int nbot = NumBotNodes();
int nobTrain=0;
int *itr;
for(int i=1;i<=nbot;i++) { // loop over bottom nodes-------------
//data is list of indices of train obs in the bottom node
List& data = ((Node *)botvec[i])->DataList;
nobTrain = data.length;
itr = new int[nobTrain+1]; //copy list contents to itr
Cell *cell = data.first;
if(nobTrain>0) itr[1]=*((int *)(cell->contents));
ybar = yTrain[itr[1]];
for(int j=2;j<=nobTrain;j++) {
cell = cell->after;
itr[j]=*((int *)(cell->contents));
ybar += yTrain[itr[j]];
}
ybar /= nobTrain;
b=nobTrain/mod->getSigma2();a=mod->getA();
postmu = b*ybar/(a+b); postsd = 1.0/sqrt(a+b);
nodeMu = postmu + postsd*norm_rand();
for(int j=1;j<=nTest;j++) {if(indPartTest[j]==i) fits[2][j]=nodeMu; }
for(int j=1;j<=nobTrain;j++) fits[1][itr[j]] = nodeMu;
delete [] itr;
} //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
if(nTest) delete [] indPartTest;
delete [] botvec;
}
void drmu(std::vector<std::vector<double> >& X, tree& t, xinfo& xi, dinfo& di, pinfo& pi)
{
GetRNGstate();
tree::npv bnv;
std::vector<sinfo> sv;
allsuff(X, t,xi,di,bnv,sv);
double a = 1.0/(pi.tau * pi.tau);
double sig2 = pi.sigma * pi.sigma;
double b,ybar;
for(tree::npv::size_type i=0;i!=bnv.size();i++) {
b = sv[i].n/sig2;
ybar = sv[i].sy/sv[i].n;
bnv[i]->setm(b*ybar/(a+b) + norm_rand()/sqrt(a+b));
}
PutRNGstate();
}
// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
// copula for data with missing values
// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
void copula_NA( double Z[], double K[], int R[], int not_continuous[], int *n, int *p )
{
int number = *n, dim = *p, nxp = number * dim, dimp1 = dim + 1;
#pragma omp parallel
{
double sigma, sd_j, mu_ij, lb, ub, runif_value, pnorm_lb, pnorm_ub;
int i, j;
#pragma omp for
for( int counter = 0; counter < nxp; counter++ )
{
j = counter / number;
i = counter % number;
if( not_continuous[ j ] )
{
sigma = 1.0 / K[ j * dimp1 ]; // 1.0 / K[ j * dim + j ];
sd_j = sqrt( sigma );
get_mean( Z, K, &mu_ij, &sigma, &i, &j, &number, &dim );
if( R[ counter ] != 0 )
{
get_bounds_NA( Z, R, &lb, &ub, &i, &j, &number );
pnorm_lb = Rf_pnorm5( lb, mu_ij, sd_j, TRUE, FALSE );
pnorm_ub = Rf_pnorm5( ub, mu_ij, sd_j, TRUE, FALSE );
//runif_value = runif( pnorm_lb, pnorm_ub );
runif_value = pnorm_lb + unif_rand() * ( pnorm_ub - pnorm_lb );
Z[ counter ] = Rf_qnorm5( runif_value, mu_ij, sd_j, TRUE, FALSE );
}else
Z[ counter ] = mu_ij + norm_rand() * sd_j; // rnorm( mu_ij, sd_j );
}
}
}
}
void MARprobit(int *Y, /* binary outcome variable */
int *Ymiss, /* missingness indicator for Y */
int *iYmax, /* maximum value of Y; 0,1,...,Ymax */
int *Z, /* treatment assignment */
int *D, /* treatment status */
int *C, /* compliance status */
double *dX, double *dXo, /* covariates */
double *dBeta, double *dGamma, /* coefficients */
int *iNsamp, int *iNgen, int *iNcov, int *iNcovo,
int *iNcovoX, int *iN11,
/* counters */
double *beta0, double *gamma0, double *dA, double *dAo, /*prior */
int *insample, /* 1: insample inference, 2: conditional inference */
int *smooth,
int *param, int *mda, int *iBurnin,
int *iKeep, int *verbose, /* options */
double *pdStore
) {
/*** counters ***/
int n_samp = *iNsamp; /* sample size */
int n_gen = *iNgen; /* number of gibbs draws */
int n_cov = *iNcov; /* number of covariates */
int n_covo = *iNcovo; /* number of all covariates for outcome model */
int n_covoX = *iNcovoX; /* number of covariates excluding smooth
terms */
int n11 = *iN11; /* number of compliers in the treament group */
/*** data ***/
double **X; /* covariates for the compliance model */
double **Xo; /* covariates for the outcome model */
double *W; /* latent variable */
int Ymax = *iYmax;
/*** model parameters ***/
double *beta; /* coef for compliance model */
double *gamma; /* coef for outcomme model */
double *q; /* some parameters for sampling C */
double *pc;
double *pn;
double pcmean;
double pnmean;
double **SS; /* matrix folders for SWEEP */
double **SSo;
// HJ commented it out on April 17, 2018
// double **SSr;
double *meanb; /* means for beta and gamma */
double *meano;
double *meanr;
double **V; /* variances for beta and gamma */
double **Vo;
double **Vr;
double **A;
double **Ao;
double *tau; /* thresholds: tau_0, ..., tau_{Ymax-1} */
double *taumax; /* corresponding max and min for tau */
double *taumin; /* tau_0 is fixed to 0 */
double *treat; /* smooth function for treat */
/*** quantities of interest ***/
int n_comp, n_compC, n_ncompC;
double *ITTc;
double *base;
/*** storage parameters and loop counters **/
int progress = 1;
int keep = 1;
int i, j, k, main_loop;
int itemp, itempP = ftrunc((double) n_gen/10);
double dtemp, ndraw, cdraw;
double *vtemp;
double **mtemp, **mtempo;
/*** marginal data augmentation ***/
double sig2 = 1;
int nu0 = 1;
double s0 = 1;
/*** get random seed **/
GetRNGstate();
/*** define vectors and matricies **/
X = doubleMatrix(n_samp+n_cov, n_cov+1);
Xo = doubleMatrix(n_samp+n_covo, n_covo+1);
W = doubleArray(n_samp);
tau = doubleArray(Ymax);
taumax = doubleArray(Ymax);
taumin = doubleArray(Ymax);
SS = doubleMatrix(n_cov+1, n_cov+1);
SSo = doubleMatrix(n_covo+1, n_covo+1);
// HJ commented it out on April 17, 2018
// SSr = doubleMatrix(4, 4);
V = doubleMatrix(n_cov, n_cov);
Vo = doubleMatrix(n_covo, n_covo);
Vr = doubleMatrix(3, 3);
beta = doubleArray(n_cov);
gamma = doubleArray(n_covo);
meanb = doubleArray(n_cov);
meano = doubleArray(n_covo);
meanr = doubleArray(3);
q = doubleArray(n_samp);
pc = doubleArray(n_samp);
pn = doubleArray(n_samp);
A = doubleMatrix(n_cov, n_cov);
Ao = doubleMatrix(n_covo, n_covo);
vtemp = doubleArray(n_samp);
mtemp = doubleMatrix(n_cov, n_cov);
mtempo = doubleMatrix(n_covo, n_covo);
ITTc = doubleArray(Ymax+1);
treat = doubleArray(n11);
base = doubleArray(2);
/*** read the data ***/
itemp = 0;
for (j =0; j < n_cov; j++)
for (i = 0; i < n_samp; i++)
X[i][j] = dX[itemp++];
itemp = 0;
for (j =0; j < n_covo; j++)
for (i = 0; i < n_samp; i++)
Xo[i][j] = dXo[itemp++];
/*** read the prior and it as additional data points ***/
itemp = 0;
for (k = 0; k < n_cov; k++)
for (j = 0; j < n_cov; j++)
A[j][k] = dA[itemp++];
itemp = 0;
for (k = 0; k < n_covo; k++)
for (j = 0; j < n_covo; j++)
Ao[j][k] = dAo[itemp++];
dcholdc(A, n_cov, mtemp);
for(i = 0; i < n_cov; i++) {
X[n_samp+i][n_cov]=0;
for(j = 0; j < n_cov; j++) {
X[n_samp+i][n_cov] += mtemp[i][j]*beta0[j];
X[n_samp+i][j] = mtemp[i][j];
}
}
dcholdc(Ao, n_covo, mtempo);
for(i = 0; i < n_covo; i++) {
Xo[n_samp+i][n_covo]=0;
for(j = 0; j < n_covo; j++) {
Xo[n_samp+i][n_covo] += mtempo[i][j]*gamma0[j];
Xo[n_samp+i][j] = mtempo[i][j];
}
}
/*** starting values ***/
for (i = 0; i < n_cov; i++)
beta[i] = dBeta[i];
for (i = 0; i < n_covo; i++)
gamma[i] = dGamma[i];
if (Ymax > 1) {
tau[0] = 0.0;
taumax[0] = 0.0;
taumin[0] = 0.0;
for (i = 1; i < Ymax; i++)
tau[i] = tau[i-1]+2/(double)(Ymax-1);
}
for (i = 0; i < n_samp; i++) {
pc[i] = unif_rand();
pn[i] = unif_rand();
}
/*** Gibbs Sampler! ***/
itemp=0;
for(main_loop = 1; main_loop <= n_gen; main_loop++){
/** COMPLIANCE MODEL **/
if (*mda) sig2 = s0/rchisq((double)nu0);
/* Draw complier status for control group */
for(i = 0; i < n_samp; i++){
dtemp = 0;
for(j = 0; j < n_cov; j++)
dtemp += X[i][j]*beta[j];
if(Z[i] == 0){
q[i] = pnorm(dtemp, 0, 1, 1, 0);
if(unif_rand() < (q[i]*pc[i]/(q[i]*pc[i]+(1-q[i])*pn[i]))) {
C[i] = 1; Xo[i][1] = 1;
}
else {
C[i] = 0; Xo[i][1] = 0;
}
}
/* Sample W */
if(C[i]==0)
W[i] = TruncNorm(dtemp-100,0,dtemp,1,0);
else
W[i] = TruncNorm(0,dtemp+100,dtemp,1,0);
X[i][n_cov] = W[i]*sqrt(sig2);
W[i] *= sqrt(sig2);
}
/* SS matrix */
for(j = 0; j <= n_cov; j++)
for(k = 0; k <= n_cov; k++)
SS[j][k]=0;
for(i = 0; i < n_samp+n_cov; i++)
for(j = 0; j <= n_cov; j++)
for(k = 0; k <= n_cov; k++)
SS[j][k] += X[i][j]*X[i][k];
/* SWEEP SS matrix */
for(j = 0; j < n_cov; j++)
SWP(SS, j, n_cov+1);
/* draw beta */
for(j = 0; j < n_cov; j++)
meanb[j] = SS[j][n_cov];
if (*mda)
sig2=(SS[n_cov][n_cov]+s0)/rchisq((double)n_samp+nu0);
for(j = 0; j < n_cov; j++)
for(k = 0; k < n_cov; k++) V[j][k] = -SS[j][k]*sig2;
rMVN(beta, meanb, V, n_cov);
/* rescale the parameters */
if(*mda) {
for (i = 0; i < n_cov; i++) beta[i] /= sqrt(sig2);
}
/** OUTCOME MODEL **/
/* Sample W */
if (Ymax > 1) { /* tau_0=0, tau_1, ... */
for (j = 1; j < (Ymax - 1); j++) {
taumax[j] = tau[j+1];
taumin[j] = tau[j-1];
}
taumax[Ymax-1] = tau[Ymax-1]+100;
taumin[Ymax-1] = tau[Ymax-2];
}
if (*mda) sig2 = s0/rchisq((double)nu0);
for (i = 0; i < n_samp; i++){
dtemp = 0;
for (j = 0; j < n_covo; j++) dtemp += Xo[i][j]*gamma[j];
if (Ymiss[i] == 1) {
W[i] = dtemp + norm_rand();
if (Ymax == 1) { /* binary probit */
if (W[i] > 0) Y[i] = 1;
else Y[i] = 0;
}
else { /* ordered probit */
if (W[i] >= tau[Ymax-1])
Y[i] = Ymax;
else {
j = 0;
while (W[i] > tau[j] && j < Ymax) j++;
Y[i] = j;
}
}
}
else {
if(Ymax == 1) { /* binary probit */
if(Y[i] == 0) W[i] = TruncNorm(dtemp-100,0,dtemp,1,0);
else W[i] = TruncNorm(0,dtemp+100,dtemp,1,0);
}
else { /* ordered probit */
if (Y[i] == 0)
W[i] = TruncNorm(dtemp-100, 0, dtemp, 1, 0);
else if (Y[i] == Ymax) {
W[i] = TruncNorm(tau[Ymax-1], dtemp+100, dtemp, 1, 0);
if (W[i] < taumax[Ymax-1]) taumax[Ymax-1] = W[i];
}
else {
W[i] = TruncNorm(tau[Y[i]-1], tau[Y[i]], dtemp, 1, 0);
if (W[i] > taumin[Y[i]]) taumin[Y[i]] = W[i];
if (W[i] < taumax[Y[i]-1]) taumax[Y[i]-1] = W[i];
}
}
}
Xo[i][n_covo] = W[i]*sqrt(sig2);
W[i] *= sqrt(sig2);
}
/* draw tau */
if (Ymax > 1)
for (j = 1; j < Ymax; j++)
tau[j] = runif(taumin[j], taumax[j])*sqrt(sig2);
/* SS matrix */
for(j = 0; j <= n_covo; j++)
for(k = 0; k <= n_covo; k++)
SSo[j][k]=0;
for(i = 0;i < n_samp+n_covo; i++)
for(j = 0;j <= n_covo; j++)
for(k = 0; k <= n_covo; k++)
SSo[j][k] += Xo[i][j]*Xo[i][k];
/* SWEEP SS matrix */
for(j = 0; j < n_covo; j++)
SWP(SSo, j, n_covo+1);
/* draw gamma */
for(j = 0; j < n_covo; j++)
meano[j] = SSo[j][n_covo];
if (*mda)
sig2=(SSo[n_covo][n_covo]+s0)/rchisq((double)n_samp+nu0);
for(j = 0; j < n_covo; j++)
for(k = 0; k < n_covo; k++) Vo[j][k]=-SSo[j][k]*sig2;
rMVN(gamma, meano, Vo, n_covo);
/* rescaling the parameters */
if(*mda) {
for (i = 0; i < n_covo; i++) gamma[i] /= sqrt(sig2);
if (Ymax > 1)
for (i = 1; i < Ymax; i++)
tau[i] /= sqrt(sig2);
}
/* computing smooth terms */
if (*smooth) {
for (i = 0; i < n11; i++) {
treat[i] = 0;
for (j = n_covoX; j < n_covo; j++)
treat[i] += Xo[i][j]*gamma[j];
}
}
/** Compute probabilities **/
for(i = 0; i < n_samp; i++){
vtemp[i] = 0;
for(j = 0; j < n_covo; j++)
vtemp[i] += Xo[i][j]*gamma[j];
}
for(i = 0; i < n_samp; i++){
if(Z[i]==0){
if (C[i] == 1) {
pcmean = vtemp[i];
if (*smooth)
pnmean = vtemp[i]-gamma[0];
else
pnmean = vtemp[i]-gamma[1];
}
else {
if (*smooth)
pcmean = vtemp[i]+gamma[0];
else
pcmean = vtemp[i]+gamma[1];
pnmean = vtemp[i];
}
if (Y[i] == 0){
pc[i] = pnorm(0, pcmean, 1, 1, 0);
pn[i] = pnorm(0, pnmean, 1, 1, 0);
}
else {
if (Ymax == 1) { /* binary probit */
pc[i] = pnorm(0, pcmean, 1, 0, 0);
pn[i] = pnorm(0, pnmean, 1, 0, 0);
}
else { /* ordered probit */
if (Y[i] == Ymax) {
pc[i] = pnorm(tau[Ymax-1], pcmean, 1, 0, 0);
pn[i] = pnorm(tau[Ymax-1], pnmean, 1, 0, 0);
}
else {
pc[i] = pnorm(tau[Y[i]], pcmean, 1, 1, 0) -
pnorm(tau[Y[i]-1], pcmean, 1, 1, 0);
pn[i] = pnorm(tau[Y[i]], pnmean, 1, 1, 0) -
pnorm(tau[Y[i]-1], pnmean, 1, 1, 0);
}
}
}
}
}
/** Compute quantities of interest **/
n_comp = 0; n_compC = 0; n_ncompC = 0; base[0] = 0; base[1] = 0;
for (i = 0; i <= Ymax; i++)
ITTc[i] = 0;
if (*smooth) {
for(i = 0; i < n11; i++){
if(C[i] == 1) {
n_comp++;
if (Z[i] == 0) {
n_compC++;
base[0] += (double)Y[i];
}
pcmean = vtemp[i];
pnmean = vtemp[i]-treat[i]+gamma[0];
ndraw = rnorm(pnmean, 1);
cdraw = rnorm(pcmean, 1);
if (*insample && Ymiss[i]==0)
dtemp = (double)(Y[i]==0) - (double)(ndraw < 0);
else
dtemp = pnorm(0, pcmean, 1, 1, 0) - pnorm(0, pnmean, 1, 1, 0);
ITTc[0] += dtemp;
if (Ymax == 1) { /* binary probit */
if (*insample && Ymiss[i]==0)
dtemp = (double)Y[i] - (double)(ndraw > 0);
else
dtemp = pnorm(0, pcmean, 1, 0, 0) - pnorm(0, pnmean, 1, 0, 0);
ITTc[1] += dtemp;
}
else { /* ordered probit */
if (*insample && Ymiss[i]==0)
dtemp = (double)(Y[i]==Ymax) - (double)(ndraw > tau[Ymax-1]);
else
dtemp = pnorm(tau[Ymax-1], pcmean, 1, 0, 0) -
pnorm(tau[Ymax-1], pnmean, 1, 0, 0);
ITTc[Ymax] += dtemp;
for (j = 1; j < Ymax; j++) {
if (*insample && Ymiss[i]==0)
dtemp = (double)(Y[i]==j) - (double)(ndraw < tau[j] &&
ndraw > tau[j-1]);
else
dtemp = (pnorm(tau[j], pcmean, 1, 1, 0) -
pnorm(tau[j-1], pcmean, 1, 1, 0))
- (pnorm(tau[j], pnmean, 1, 1, 0) -
pnorm(tau[j-1], pnmean, 1, 1, 0));
ITTc[j] += dtemp;
}
}
}
else
if (Z[i] == 0) {
n_ncompC++;
base[1] += (double)Y[i];
}
}
}
else {
for(i = 0; i < n_samp; i++){
if(C[i] == 1) {
n_comp++;
if (Z[i] == 1) {
pcmean = vtemp[i];
pnmean = vtemp[i]-gamma[0]+gamma[1];
}
else {
n_compC++;
base[0] += (double)Y[i];
pcmean = vtemp[i]+gamma[0]-gamma[1];
pnmean = vtemp[i];
}
ndraw = rnorm(pnmean, 1);
cdraw = rnorm(pcmean, 1);
if (*insample && Ymiss[i]==0) {
if (Z[i] == 1)
dtemp = (double)(Y[i]==0) - (double)(ndraw < 0);
else
dtemp = (double)(cdraw < 0) - (double)(Y[i]==0);
}
else
dtemp = pnorm(0, pcmean, 1, 1, 0) - pnorm(0, pnmean, 1, 1, 0);
ITTc[0] += dtemp;
if (Ymax == 1) { /* binary probit */
if (*insample && Ymiss[i]==0) {
if (Z[i] == 1)
dtemp = (double)Y[i] - (double)(ndraw > 0);
else
dtemp = (double)(cdraw > 0) - (double)Y[i];
}
else
dtemp = pnorm(0, pcmean, 1, 0, 0) - pnorm(0, pnmean, 1, 0, 0);
ITTc[1] += dtemp;
}
else { /* ordered probit */
if (*insample && Ymiss[i]==0) {
if (Z[i] == 1)
dtemp = (double)(Y[i]==Ymax) - (double)(ndraw > tau[Ymax-1]);
else
dtemp = (double)(cdraw > tau[Ymax-1]) - (double)(Y[i]==Ymax);
}
else
dtemp = pnorm(tau[Ymax-1], pcmean, 1, 0, 0) -
pnorm(tau[Ymax-1], pnmean, 1, 0, 0);
ITTc[Ymax] += dtemp;
for (j = 1; j < Ymax; j++) {
if (*insample && Ymiss[i]==0) {
if (Z[i] == 1)
dtemp = (double)(Y[i]==j) - (double)(ndraw < tau[j] && ndraw > tau[j-1]);
else
dtemp = (pnorm(tau[j], pcmean, 1, 1, 0) -
pnorm(tau[j-1], pcmean, 1, 1, 0)) - (double)(Y[i]==j);
}
else
dtemp = (pnorm(tau[j], pcmean, 1, 1, 0) -
pnorm(tau[j-1], pcmean, 1, 1, 0))
- (pnorm(tau[j], pnmean, 1, 1, 0) -
pnorm(tau[j-1], pnmean, 1, 1, 0));
ITTc[j] += dtemp;
}
}
}
else
if (Z[i] == 0) {
n_ncompC++;
base[1] += (double)Y[i];
}
}
}
/** storing the results **/
if (main_loop > *iBurnin) {
if (keep == *iKeep) {
pdStore[itemp++]=(double)n_comp/(double)n_samp;
if (Ymax == 1) {
pdStore[itemp++]=ITTc[1]/(double)n_comp;
pdStore[itemp++]=ITTc[1]/(double)n_samp;
pdStore[itemp++] = base[0]/(double)n_compC;
pdStore[itemp++] = base[1]/(double)n_ncompC;
pdStore[itemp++] = (base[0]+base[1])/(double)(n_compC+n_ncompC);
}
else {
for (i = 0; i <= Ymax; i++)
pdStore[itemp++]=ITTc[i]/(double)n_comp;
for (i = 0; i <= Ymax; i++)
pdStore[itemp++]=ITTc[i]/(double)n_samp;
}
if (*param) {
for(i = 0; i < n_cov; i++)
pdStore[itemp++]=beta[i];
if (*smooth) {
for(i = 0; i < n_covoX; i++)
pdStore[itemp++]=gamma[i];
for(i = 0; i < n11; i++)
pdStore[itemp++]=treat[i];
}
else
for(i = 0; i < n_covo; i++)
pdStore[itemp++]=gamma[i];
if (Ymax > 1)
for (i = 0; i < Ymax; i++)
pdStore[itemp++]=tau[i];
}
keep = 1;
}
else
keep++;
}
if(*verbose) {
if(main_loop == itempP) {
Rprintf("%3d percent done.\n", progress*10);
itempP += ftrunc((double) n_gen/10);
progress++;
R_FlushConsole();
}
}
R_FlushConsole();
R_CheckUserInterrupt();
} /* end of Gibbs sampler */
/** write out the random seed **/
PutRNGstate();
/** freeing memory **/
FreeMatrix(X, n_samp+n_cov);
FreeMatrix(Xo, n_samp+n_covo);
free(W);
free(beta);
free(gamma);
free(q);
free(pc);
free(pn);
FreeMatrix(SS, n_cov+1);
FreeMatrix(SSo, n_covo+1);
free(meanb);
free(meano);
free(meanr);
FreeMatrix(V, n_cov);
FreeMatrix(Vo, n_covo);
FreeMatrix(Vr, 3);
FreeMatrix(A, n_cov);
FreeMatrix(Ao, n_covo);
free(tau);
free(taumax);
free(taumin);
free(ITTc);
free(vtemp);
free(treat);
free(base);
FreeMatrix(mtemp, n_cov);
FreeMatrix(mtempo, n_covo);
} /* main */
void twosample_incidence_ks(int *event, int *group, int *n, int *nsim,
double *f11, double *f12, double *f21, double *f22, double *test_process,
double *stat, double *pval_sim, double *test_process_plot_sim, int *nsim_plot)
{
GetRNGstate();
int i,j,n1,n2;
double temp;
int *y1,*y2;
y1 = (int *) R_alloc(2**n,sizeof(int));
y2 = y1 + *n;
double *s1,*s2,*test_process_sim,*g,*f01;
s1 = (double *) R_alloc(5**n,sizeof(double));
s2 = s1 + *n;
test_process_sim = s2 + *n;
g = test_process_sim + *n;
f01 = g + *n;
double stat_sim;
/* OBSERVED test statistic */
twosample_incidence_ks_process(event, group, n, y1, y2, f11, f12, f21, f22,
s1, s2, test_process);
*stat = ks_stat_cum(test_process, n);
n1 = y1[0];
n2 = y2[0];
/* null (pooled sample) estimator of the cause 1 cif */
twosample_incidence_f01(event, y1, y2, s1, s2, f01, n);
/* LWY SIMULATION */
/* simulated processes are computed with the pooled sample estimator f01 */
/* (simulations with pooled sample f01 lead to conservative test, */
/* recommended by Bajorunatite & Klein (2007, CSDA); */
/* individual f11, f21 give anticonserv. approximation) */
if (*nsim>0) {
*pval_sim = 0.;
/* *pval_sim_indiv = 0.; */
for (j=0; j<*nsim_plot; j++) { /* always must be *nsim>=*nsim_plot */
for (i=0; i<*n; i++) {
g[i] = norm_rand();
}
/* compute the resampled test process with pooled sample f01 */
twosample_incidence_lwy_process(event, group, n, y1, y2, f01, f12, f01, f22,
g, test_process_sim);
stat_sim = ks_stat_cum(test_process_sim, n);
*pval_sim += (double) (stat_sim > *stat);
/* save the simulated process for plotting */
for (i=0; i<*n; i++)
test_process_plot_sim[i+j**n] = test_process_sim[i];
/* resampling with individual f11,f21; not used */
/*
twosample_incidence_lwy_process(event, group, n, y1, y2, f11, f12, f21, f22,
g, test_process_sim);
stat_sim = ks_stat_cum(test_process_sim, n, i1, i2);
*pval_sim_indiv += (double) (stat_sim > *stat);
*/
}
for (j=*nsim_plot; j<*nsim; j++) {
for (i=0; i<*n; i++) {
g[i] = norm_rand();
}
/* compute the resampled test process with pooled sample f01 */
twosample_incidence_lwy_process(event, group, n, y1, y2, f01, f12, f01, f22,
g, test_process_sim);
stat_sim = ks_stat_cum(test_process_sim, n);
*pval_sim += (double) (stat_sim > *stat);
/* resampling with individual f11,f21; not used */
/*
twosample_incidence_lwy_process(event, group, n, y1, y2, f11, f12, f21, f22,
g, test_process_sim);
stat_sim = ks_stat_cum(test_process_sim, n, i1, i2);
*pval_sim_indiv += (double) (stat_sim > *stat);
*/
}
*pval_sim /= *nsim;
/* *pval_sim_indiv /= *nsim; */
}
PutRNGstate();
}