double rF(double n1, double n2, RNG *rng)
{
double v1, v2;
if (ISNAN(n1) || ISNAN(n2) || n1 <= 0. || n2 <= 0.)
ML_ERR_return_NAN;
v1 = R_FINITE(n1) ? (rchisq(n1, rng) / n1) : 1;
v2 = R_FINITE(n2) ? (rchisq(n2, rng) / n2) : 1;
return v1 / v2;
}
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();
}
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);
}
}
double rnchisq(double df, double lambda)
{
if (!R_FINITE(df) || !R_FINITE(lambda) || df < 0. || lambda < 0.)
ML_ERR_return_NAN;
if(lambda == 0.) {
return (df == 0.) ? 0. : rgamma(df / 2., 2.);
}
else {
double r = rpois( lambda / 2.);
if (r > 0.) r = rchisq(2. * r);
if (df > 0.) r += rgamma(df / 2., 2.);
return r;
}
}
cs *cs_rinvwishart(const cs *A, double nu, const css *As){
int m, i, j, cnt;
cs *T, *IW, *C, *W, *tC;
csn *U;
m = A->n;
T = cs_spalloc (m, m, m*(m+1)/2, 1, 0) ;
if (!T ) return (cs_done (T, NULL, NULL, 0));
double df = nu;
cnt = 0;
for(i = 0; i<m; i++){
T->p[i] = cnt;
T->i[cnt] = i;
T->x[cnt] = sqrt(rchisq(df));
cnt++;
for(j = i+1; j<m; j++){
T->i[cnt] = j;
T->x[cnt] = rnorm(0.0,1.0);
cnt++;
}
df--;
}
T->p[m] = m*(m+1)/2;
U = cs_chol(A, As);
if(U==NULL){
PutRNGstate();
error("ill-conditioned cross-product: can't form Cholesky factor\n");
}
C = cs_multiply(U->L,T); // t(T)%*%chol(A)
tC = cs_transpose(C, TRUE); // t(CI)
W = cs_multiply(C,tC);
IW = cs_inv(W); // crossprod(t(CI))
cs_spfree(T);
cs_nfree(U);
cs_spfree(C);
cs_spfree(tC);
cs_spfree(W);
return (cs_done (IW, NULL, NULL, 1)) ; /* success; free workspace, return C */
}
/**
* 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;
}
// [[Rcpp::export]]
List rwishart(double nu, mat const& V){
// Wayne Taylor 4/7/2015
// Function to draw from Wishart (nu,V) and IW
// W ~ W(nu,V)
// E[W]=nuV
// WI=W^-1
// E[WI]=V^-1/(nu-m-1)
// T has sqrt chisqs on diagonal and normals below diagonal
int m = V.n_rows;
mat T = zeros(m,m);
for(int i = 0; i < m; i++) {
T(i,i) = sqrt(rchisq(1,nu-i)[0]); //rchisq returns a vectorized object, so using [0] allows for the conversion to double
}
for(int j = 0; j < m; j++) {
for(int i = j+1; i < m; i++) {
T(i,j) = rnorm(1)[0]; //rnorm returns a NumericVector, so using [0] allows for conversion to double
}}
mat C = trans(T)*chol(V);
mat CI = solve(trimatu(C),eye(m,m)); //trimatu interprets the matrix as upper triangular and makes solve more efficient
// C is the upper triangular root of Wishart therefore, W=C'C
// this is the LU decomposition Inv(W) = CICI' Note: this is
// the UL decomp not LU!
// W is Wishart draw, IW is W^-1
return List::create(
Named("W") = trans(C) * C,
Named("IW") = CI * trans(CI),
Named("C") = C,
Named("CI") = CI);
}
double TruncT(double lb, /* lower bound */
double ub, /* upper bound */
double mu, /* mean */
int df, /* degrees of freedom */
double var, /* scale^2 */
int invcdf /* use inverse cdf method? */
) {
double z;
double dtemp;
double sigma = sqrt(var);
double stlb = (lb-mu)/sigma; /* standardized lower bound */
double stub = (ub-mu)/sigma; /* standardized upper bound */
if (invcdf) {
z = qt(runif(pt(stlb, df, 1, 0), pt(stub, df, 1, 0)), df, 1, 0);
return(z*sigma + mu);
} else {
dtemp = var*((double) df)/rchisq(df);
z = TruncNorm(lb, ub, mu, dtemp, 0);
return(z);
}
}
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 ComputeMaxima(double *df, double *maxima, int *model, int *nblock,
int *nsite, double *simu)
{
int i=0, k=0;
double an=0.0, bn=0.0, chi2=1.0, n=0.0;
// Seeting: normalizing constants for the Student t
// and Gaussian model
n = (double) *nblock;
/* switch(*model)
{
case 1:
an = qt(1 - 1 / n, *df, 1, 0);
bn = 0;
// First loop: number of blocks
for(i = 0; i < *nblock; i++)
{
chi2 = sqrt(rchisq(*df) / *df);
// Second loop: number of sites
for(k = 0; k < *nsite; k++)
{
simu[k + i * *nsite] = simu[k + i * *nsite] / chi2;
maxima[k] = fmax(maxima[k], (simu[k + i * *nsite] - bn) / an);
}
}
break;
case 2:
bn = sqrt(2 * log(n)) -
(0.5 * log(log(n)) + log(2 * sqrt(M_PI))) /
sqrt(2 * log(n));
an = 1 / bn;
// First loop: number of blocks
for(i = 0; i < *nblock; i++)
{
// Second loop: number of sites
for(k = 0; k < *nsite; k++)
maxima[k] = fmax(maxima[k], simu[k + i * *nsite]);
if(i == (*nblock - 1))
maxima[k] = (maxima[k] - bn) / an;
}
break;
}*/
if(*model==1)
{
bn = sqrt(2 * log(n)) -
(0.5 * log(log(n)) + log(2 * sqrt(M_PI))) /
sqrt(2 * log(n));
an = 1 / bn;
// First loop: number of blocks
for(i = 0; i < *nblock; i++)
{
// Second loop: number of sites
for(k = 0; k < *nsite; k++)
{
// Compute the componentwise maxima
maxima[k] = fmax(maxima[k], simu[k + i * *nsite]);
if(i == (*nblock - 1))
maxima[k] = (maxima[k] - bn) / an;
}
}
}
if(*model==2)
{
an = qt(1 - 1 / n, *df, 1, 0);
bn = 0;
// First loop: number of blocks
for(i = 0; i < *nblock; i++)
{
chi2 = sqrt(rchisq(*df) / *df);
// Second loop: number of sites
for(k = 0; k < *nsite; k++)
{
// Compute the componentwise maxima
maxima[k] = fmax(maxima[k], simu[k + i * *nsite] / chi2);
if(i == (*nblock - 1))
maxima[k] = (maxima[k] - bn) / an;
}
}
}
// First loop: number of blocks
/* for(i = 0; i < *nblock; i++)
{
// Second loop: number of sites
for(k = 0; k < *nsite; k++)
maxima[k] = fmax(maxima[k], simu[k + i * *nsite] - bn);
if(i == (*nblock - 1))
maxima[k] = (maxima[k] - bn) / an;
}*/
// First loop: number of blocks
/* for(i = 0; i < *nblock; i++)
{
if(*model == 1)
chi2 = sqrt(rchisq(*df) / *df);
// Second loop: number of sites
for(k = 0; k < *nsite; k++)
{ // Compute the componentwise maxima
maxima[k] = fmax(maxima[k], simu[k + i * *nsite] / chi2);
if(i == (*nblock - 1))
maxima[k] = (maxima[k] - bn) / an;
}
}*/
return;
}
