/* this one genrealizes the previous code and accepts a vector of k (length m)
and matrix of p (m copies of l dimensional vector) */
void RpoisbinomEffMatrix(int *k, int *maxk, double *p, int *l, int *m, double *Rs) {
double ptmp, *dtmp, *sumT;
int h, i, j;
dtmp = doubleArray(*maxk+1);
sumT = doubleArray(*maxk);
for (h = 0; h < *m; h++) {
dtmp[0] = 1.0;
if (k[h] > 0) {
for (i = 1; i <= k[h]; i++) {
dtmp[i] = 0.0;
sumT[i-1] = 0.0;
for (j = 0; j < *l; j++) {
ptmp = p[h*l[0]+j];
sumT[i-1] += R_pow_di(ptmp/(1-ptmp), i);
}
for (j = 1; j <= i; j++) {
dtmp[i] += R_pow_di(-1.0, j+1) * sumT[j-1] * dtmp[i-j];
}
dtmp[i] /= i;
}
}
Rs[h] = dtmp[k[h]];
}
free(dtmp);
free(sumT);
}
void Vector<T>::swap(Vector v2)
{
int tempsize = 0;//stores the size of the larger Vector
//finds the size of the larger vector
if (v2.size() > size)
tempSize = v2.size;
else
tempsize = size;
while (size < tempSize)//makes this array larger if it is to small
{
doubleArray();
}
T tempArray[v2.size()];//this will hold the contents of v2 after v2 is cleared
int v2Size = v2.size();//this will hold the size of v2 after it is cleared
//this loop will populate tempArray with the elements v2
for (int i = 0;i < tempsize;i++)
{
tempArray[i] = v2.at(i);//copies each element from v2 into tempArray
}
v2.clear();//clears v2 so elements from this array can be pushed in
//this loop will repopulate both vectors
for (int i = 0;i < tempsize;i++)
{
v2.push_back(list[i]);//puts the element at i in this vector at i in v2
list[i] = tempArray[i];//puts the element that was at i in v2 at i in this vector
}
size = v2Size;//sets the size of this array
}
void Vector<T>::push_back(T element)
{
if (size >= maxSize)
doubleArray();
size++;
list[size] = element;
}
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);
}
bool DynamicCheckbook<DataType>::writeCheck(float amt)
{
if (amt > balance)
return false;
balance -= amt;
if(numChecksWritten == numChecks)
doubleArray();
checks[numChecksWritten].amount = amt;
checks[numChecksWritten].checkNumber = (numChecksWritten+1);
numChecksWritten++;
return true;
}
/* Grid method samping from tomography line*/
void rGrid(
double *Sample, /* W_i sampled from each tomography line */
double *W1gi, /* The grid lines of W1[i] */
double *W2gi, /* The grid lines of W2[i] */
int ni_grid, /* number of grids for observation i*/
double *mu, /* mean vector for normal */
double **InvSigma, /* Inverse covariance matrix for normal */
int n_dim) /* dimension of parameters */
{
int j;
double dtemp;
double *vtemp=doubleArray(n_dim);
double *prob_grid=doubleArray(ni_grid); /* density by grid */
double *prob_grid_cum=doubleArray(ni_grid); /* cumulative density by grid */
dtemp=0;
for (j=0;j<ni_grid;j++){
vtemp[0]=log(W1gi[j])-log(1-W1gi[j]);
vtemp[1]=log(W2gi[j])-log(1-W2gi[j]);
prob_grid[j]=dMVN(vtemp, mu, InvSigma, n_dim, 1) -
log(W1gi[j])-log(W2gi[j])-log(1-W1gi[j])-log(1-W2gi[j]);
prob_grid[j]=exp(prob_grid[j]);
dtemp+=prob_grid[j];
prob_grid_cum[j]=dtemp;
}
for (j=0;j<ni_grid;j++)
prob_grid_cum[j]/=dtemp; /*standardize prob.grid */
/*2 sample W_i on the ith tomo line */
j=0;
dtemp=unif_rand();
while (dtemp > prob_grid_cum[j]) j++;
Sample[0]=W1gi[j];
Sample[1]=W2gi[j];
free(vtemp);
free(prob_grid);
free(prob_grid_cum);
}
int main()
{
int a[] = {2, 4, 6, 8, 10};
int size = sizeof(a) / sizeof(int);
int* p = doubleArray(a, size);
int k = 0;
for(k = 0; k < size; k++)
{
printf("%d\t", *(p+k));
}
printf("\n");
return 0;
}
/* sample W via MH for 2x2 table */
void rMH(
double *W, /* previous draws */
double *XY, /* X_i and Y_i */
double W1min, /* lower bound for W1 */
double W1max, /* upper bound for W1 */
double *mu, /* mean vector for normal */
double **InvSigma, /* Inverse covariance matrix for normal */
int n_dim) /* dimension of parameters */
{
int j;
double dens1, dens2, ratio;
double *Sample = doubleArray(n_dim);
double *vtemp = doubleArray(n_dim);
double *vtemp1 = doubleArray(n_dim);
/* sample W_1 from unif(W1min, W1max) */
Sample[0] = runif(W1min, W1max);
Sample[1] = XY[1]/(1-XY[0])-Sample[0]*XY[0]/(1-XY[0]);
for (j = 0; j < n_dim; j++) {
vtemp[j] = log(Sample[j])-log(1-Sample[j]);
vtemp1[j] = log(W[j])-log(1-W[j]);
}
/* acceptance ratio */
dens1 = dMVN(vtemp, mu, InvSigma, n_dim, 1) -
log(Sample[0])-log(Sample[1])-log(1-Sample[0])-log(1-Sample[1]);
dens2 = dMVN(vtemp1, mu, InvSigma, n_dim, 1) -
log(W[0])-log(W[1])-log(1-W[0])-log(1-W[1]);
ratio = fmin2(1, exp(dens1-dens2));
/* accept */
if (unif_rand() < ratio)
for (j=0; j<n_dim; j++)
W[j]=Sample[j];
free(Sample);
free(vtemp);
free(vtemp1);
}
/* preparation for Grid */
void GridPrep(
double **W1g, /* grids holder for W1 */
double **W2g, /* grids holder for W2 */
double **X, /* data: [X Y] */
double *maxW1, /* upper bound for W1 */
double *minW1, /* lower bound for W1 */
int *n_grid, /* number of grids */
int n_samp, /* sample size */
int n_step /* step size */
)
{
int i, j;
double dtemp;
double *resid = doubleArray(n_samp);
for(i=0; i<n_samp; i++)
for (j=0; j<n_step; j++){
W1g[i][j]=0;
W2g[i][j]=0;
}
for(i=0;i<n_samp;i++) {
if (X[i][1]!=0 && X[i][1]!=1) {
/* 1/n_step is the length of the grid */
dtemp=(double)1/n_step;
if ((maxW1[i]-minW1[i]) > (2*dtemp)) {
n_grid[i]=ftrunc((maxW1[i]-minW1[i])*n_step);
resid[i]=(maxW1[i]-minW1[i])-n_grid[i]*dtemp;
/*if (maxW1[i]-minW1[i]==1) resid[i]=dtemp/4; */
j=0;
while (j<n_grid[i]) {
W1g[i][j]=minW1[i]+(j+1)*dtemp-(dtemp+resid[i])/2;
if ((W1g[i][j]-minW1[i])<resid[i]/2) W1g[i][j]+=resid[i]/2;
if ((maxW1[i]-W1g[i][j])<resid[i]/2) W1g[i][j]-=resid[i]/2;
W2g[i][j]=(X[i][1]-X[i][0]*W1g[i][j])/(1-X[i][0]);
j++;
}
}
else {
W1g[i][0]=minW1[i]+(maxW1[i]-minW1[i])/3;
W2g[i][0]=(X[i][1]-X[i][0]*W1g[i][0])/(1-X[i][0]);
W1g[i][1]=minW1[i]+2*(maxW1[i]-minW1[i])/3;
W2g[i][1]=(X[i][1]-X[i][0]*W1g[i][1])/(1-X[i][0]);
n_grid[i]=2;
}
}
}
free(resid);
}
void ArrayTest::testDoubleArray() {
valarray<double> doubleArray(2);
shared_ptr<Array<double> > array = Array<double>::newArray(doubleArray, 1.0, 0.0);
CPPUNIT_ASSERT(array->size() == 2);
CPPUNIT_ASSERT(array->get(0) == 0.0);
CPPUNIT_ASSERT(array->get(1) == 0.0);
CPPUNIT_ASSERT(array->getScaleFactor() == 1.0);
CPPUNIT_ASSERT(array->getAddOffset() == 0.0);
array->set(0, 1.0);
array->set(1, 7.0);
CPPUNIT_ASSERT(array->get(0) == 1.0);
CPPUNIT_ASSERT(array->get(1) == 7.0);
}
void ArrayTest::testDoubleArrayScaled() {
valarray<double> doubleArray(2);
shared_ptr<Array<double> > array = Array<double>::newArray(doubleArray, 2.0, 0.0);
CPPUNIT_ASSERT(array->size() == 2);
CPPUNIT_ASSERT(array->get(0) == 0.0);
CPPUNIT_ASSERT(array->get(1) == 0.0);
CPPUNIT_ASSERT(array->getScaleFactor() == 2.0);
CPPUNIT_ASSERT(array->getAddOffset() == 0.0);
array->set(0, 1.0);
array->set(1, 7.0);
CPPUNIT_ASSERT(array->get(0) == 1.0);
CPPUNIT_ASSERT(array->get(1) == 7.0);
double* buffer = (double*) array->getUntypedData();
CPPUNIT_ASSERT(buffer[0] == 0.5);
CPPUNIT_ASSERT(buffer[1] == 3.5);
}
void RpoisbinomEff(int *k, double *p, int *l, double *Rs) {
double *sumT;
int i, j;
sumT = doubleArray(*k);
Rs[0] = 1.0;
if (*k > 0) {
for (i = 1; i <= *k; i++) {
Rs[i] = 0.0;
sumT[i-1] = 0.0;
for (j = 0; j < *l; j++) {
sumT[i-1] += R_pow_di(p[j]/(1-p[j]), i);
}
for (j = 1; j <= i; j++) {
Rs[i] += R_pow_di(-1.0, j+1) * sumT[j-1] * Rs[i-j];
}
Rs[i] /= i;
}
}
free(sumT);
}
/**
* Tests the excpetions associated with Dependencies
*/
TEUCHOS_UNIT_TEST(Teuchos_Dependencies, testDepExceptions){
RCP<ParameterList> list1 = RCP<ParameterList>(new ParameterList());
RCP<ParameterList> list2 = RCP<ParameterList>(new ParameterList());
list1->set("int parameter", 4, "int parameter");
list1->set("double parameter", 6.0, "double parameter");
list1->set("string parameter", "hahahaha", "string parameter");
Array<double> doubleArray(10,23.0);
list1->set("array parameter", doubleArray, "array parameter");
list1->set("bool parameter", true, "bool parameter");
RCP<AdditionFunction<int> > intFuncTester = rcp(new
AdditionFunction<int>(10));
TEST_THROW(RCP<NumberVisualDependency<int> > numValiDep =
rcp(
new NumberVisualDependency<int>(
list1->getEntryRCP("bool parameter"),
list1->getEntryRCP("double parameter"),
true,
intFuncTester)),
InvalidDependencyException);
/*
* Testing StringVisualDepenendcy exceptions.
*/
RCP<StringVisualDependency> stringVisDep;
TEST_THROW(stringVisDep = RCP<StringVisualDependency>(
new StringVisualDependency(
list1->getEntryRCP("double parameter"),
list1->getEntryRCP("int parameter"),
"cheese", true)),
InvalidDependencyException);
/*
* Testing BoolVisualDependency exceptions.
*/
TEST_THROW(RCP<BoolVisualDependency> boolVisDep =
RCP<BoolVisualDependency>(new BoolVisualDependency(
list1->getEntryRCP("int parameter"),
list1->getEntryRCP("double parameter"), false)),
InvalidDependencyException);
/**
* Tesint NumberArrayLengthDependency excpetions */
RCP<NumberArrayLengthDependency<int, double> > numArrayLengthDep;
TEST_THROW(numArrayLengthDep =
rcp(new NumberArrayLengthDependency<int, double>(
list1->getEntryRCP("double parameter"),
list1->getEntryRCP("array parameter"))),
InvalidDependencyException);
TEST_THROW(numArrayLengthDep =
rcp(new NumberArrayLengthDependency<int, double>(
list1->getEntryRCP("int parameter"),
list1->getEntryRCP("double parameter"))),
InvalidDependencyException);
/*
* Testing StringValidatorDependency exceptions.
*/
RCP<StringToIntegralParameterEntryValidator<int> >
cheeseValidator = rcp(
new StringToIntegralParameterEntryValidator<int>(
tuple<std::string>( "Swiss", "American", "Super Awesome Cheese"),
"Food Selector"
)
);
RCP<StringToIntegralParameterEntryValidator<int> >
sodaValidator = rcp(
new StringToIntegralParameterEntryValidator<int>(
tuple<std::string>( "Pepsi", "Coke", "Kurtis Cola", "Bad Cola" ),
"Food Selector"
)
);
RCP<StringToIntegralParameterEntryValidator<int> >
chipsValidator = rcp(
new StringToIntegralParameterEntryValidator<int>(
tuple<std::string>( "Lays", "Doritos", "Kurtis Super Awesome Brand"),
"Food Selector"
)
);
list1->set(
"string 2 parameter", "Swiss",
"second string parameter", cheeseValidator);
StringValidatorDependency::ValueToValidatorMap testValidatorMap1;
testValidatorMap1["Cheese"] = cheeseValidator;
testValidatorMap1["Soda"] = sodaValidator;
testValidatorMap1["Chips"] = chipsValidator;
TEST_THROW(RCP<StringValidatorDependency> stringValiDep =
RCP<StringValidatorDependency>(
new StringValidatorDependency(
list1->getEntryRCP("int parameter"),
list1->getEntryRCP("string 2 parameter"),
testValidatorMap1)),
InvalidDependencyException);
RCP<EnhancedNumberValidator<int> > intVali =
rcp(new EnhancedNumberValidator<int>(0,20));
testValidatorMap1["Candy"] = intVali;
TEST_THROW(RCP<StringValidatorDependency> stringValiDep =
RCP<StringValidatorDependency>(
new StringValidatorDependency(
list1->getEntryRCP("string parameter"),
list1->getEntryRCP("string 2 parameter"),
testValidatorMap1)),
InvalidDependencyException);
StringValidatorDependency::ValueToValidatorMap emptyMap;
TEST_THROW(RCP<StringValidatorDependency> stringValiDep =
RCP<StringValidatorDependency>(
new StringValidatorDependency(
list1->getEntryRCP("string parameter"),
list1->getEntryRCP("string 2 parameter"),
emptyMap)),
InvalidDependencyException);
/*
* Testing BoolValidatorDependency exceptions.
*/
RCP<EnhancedNumberValidator<double> > doubleVali1 =
rcp(new EnhancedNumberValidator<double>(0.0,20.0));
RCP<EnhancedNumberValidator<double> > doubleVali2 =
rcp(new EnhancedNumberValidator<double>(5.0,20.0));
list1->set("double parameter", 6.0, "double parameter", doubleVali1);
TEST_THROW(RCP<BoolValidatorDependency> boolValiDep =
RCP<BoolValidatorDependency>(
new BoolValidatorDependency(
list1->getEntryRCP("int parameter"),
list1->getEntryRCP("double parameter"),
doubleVali1,
doubleVali2)),
InvalidDependencyException);
TEST_THROW(RCP<BoolValidatorDependency> boolValiDep =
RCP<BoolValidatorDependency>(
new BoolValidatorDependency(
list1->getEntryRCP("bool parameter"),
list1->getEntryRCP("double parameter"),
intVali,
doubleVali2)),
InvalidDependencyException);
TEST_THROW(RCP<BoolValidatorDependency> boolValiDep =
RCP<BoolValidatorDependency>(
new BoolValidatorDependency(
list1->getEntryRCP("bool parameter"),
list1->getEntryRCP("double parameter"),
doubleVali1,
intVali)),
InvalidDependencyException);
/*
* Testing RangeValidatorDependency exceptions.
*/
list1->set("Cheese to Fondue", "Swiss", "the cheese to fondue");
RCP<StringToIntegralParameterEntryValidator<int> >
lowTempCheeseValidator = rcp(
new StringToIntegralParameterEntryValidator<int>(
tuple<std::string>( "PepperJack", "Swiss", "American" ),
"Cheese to Fondue"
)
);
RCP<StringToIntegralParameterEntryValidator<int> >
highTempCheeseValidator = rcp(
new StringToIntegralParameterEntryValidator<int>(
tuple<std::string>("Munster", "Provalone",
"Kurtis Super Awesome Cheese"),
"Cheese to Fondue"
)
);
list1->set(
"Cheese to Fondue", "Swiss", "the cheese to fondue",
lowTempCheeseValidator);
RangeValidatorDependency<double>::RangeToValidatorMap tempranges;
tempranges[std::pair<double,double>(100,200)] = lowTempCheeseValidator;
tempranges[std::pair<double,double>(200,300)] = highTempCheeseValidator;
TEST_THROW(
RCP<RangeValidatorDependency<double> >
cheeseTempDep = RCP<RangeValidatorDependency<double> >(
new RangeValidatorDependency<double>(
list1->getEntryRCP("string parameter"),
list1->getEntryRCP("Cheese to Fondue"),
tempranges
)
),
InvalidDependencyException
);
tempranges[std::pair<double,double>(400,800)] = intVali;
TEST_THROW(
RCP<RangeValidatorDependency<double> >
cheeseTempDep = RCP<RangeValidatorDependency<double> >(
new RangeValidatorDependency<double>(
list1->getEntryRCP("int parameter"),
list1->getEntryRCP("Cheese to Fondue"),
tempranges
)
),
InvalidDependencyException
);
RangeValidatorDependency<double>::RangeToValidatorMap emptyMap2;
TEST_THROW(
RCP<RangeValidatorDependency<double> >
emptyMapDep = RCP<RangeValidatorDependency<double> >(
new RangeValidatorDependency<double>(
list1->getEntryRCP("double parameter"),
list1->getEntryRCP("Cheese to Fondue"),
emptyMap2
)
),
InvalidDependencyException
);
RangeValidatorDependency<int>::RangeToValidatorMap badRanges;
tempranges[std::pair<int,int>(200,100)] = lowTempCheeseValidator;
TEST_THROW(
RCP<RangeValidatorDependency<int> >
cheeseTempDep = RCP<RangeValidatorDependency<int> >(
new RangeValidatorDependency<int>(
list1->getEntryRCP("string parameter"),
list1->getEntryRCP("Cheese to Fondue"),
badRanges
)
),
InvalidDependencyException
);
}
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 NIbprobitMixed(int *Y, /* binary outcome variable */
int *R, /* recording indicator for Y */
int *grp, /* group indicator */
int *in_grp, /* number of groups */
int *max_samp_grp, /* max # of obs within group */
double *dXo, /* fixed effects covariates */
double *dXr, /* fixed effects covariates */
double *dZo, /* random effects covariates */
double *dZr, /* random effects covariates */
double *beta, /* coefficients */
double *delta, /* coefficients */
double *dPsio, /* random effects variance */
double *dPsir, /* random effects variance */
int *insamp, /* # of obs */
int *incovo, /* # of fixed effects */
int *incovr, /* # of fixed effects */
int *incovoR, /* # of random effects */
int *incovrR, /* # of random effects */
int *intreat, /* # of treatments */
double *beta0, /* prior mean */
double *delta0, /* prior mean */
double *dAo, /* prior precision */
double *dAr, /* prior precision */
int *dfo, /* prior degrees of freedom */
int *dfr, /* prior degrees of freedom */
double *dS0o, /* prior scale */
double *dS0r, /* prior scale */
int *Insample, /* insample QoI */
int *param, /* store parameters? */
int *mda, /* marginal data augmentation? */
int *ndraws, /* # of gibbs draws */
int *iBurnin, /* # of burnin */
int *iKeep, /* every ?th draws to keep */
int *verbose,
double *coefo, /* storage for coefficients */
double *coefr, /* storage for coefficients */
double *sPsiO, /* storage for variance */
double *sPsiR, /* storage for variance */
double *ATE, /* storage for ATE */
double *BASE /* storage for baseline */
) {
/*** counters ***/
int n_samp = *insamp; /* sample size */
int n_gen = *ndraws; /* number of gibbs draws */
int n_grp = *in_grp; /* number of groups */
int n_covo = *incovo; /* number of fixed effects */
int n_covr = *incovr; /* number of fixed effects */
int n_covoR = *incovoR; /* number of random effects */
int n_covrR = *incovrR; /* number of random effects */
int n_treat = *intreat; /* number of treatments */
/*** data ***/
/* covariates for the response model */
double **Xr = doubleMatrix(n_samp+n_covr, n_covr+1);
/* covariates for the outcome model */
double **Xo = doubleMatrix(n_samp+n_covo, n_covo+1);
/* random effects covariates */
double ***Zo = doubleMatrix3D(n_grp, *max_samp_grp + n_covoR,
n_covoR + 1);
double ***Zr = doubleMatrix3D(n_grp, *max_samp_grp + n_covrR,
n_covrR + 1);
/*** model parameters ***/
double **PsiO = doubleMatrix(n_covoR, n_covoR);
double **PsiR = doubleMatrix(n_covrR, n_covrR);
double **xiO = doubleMatrix(n_grp, n_covoR);
double **xiR = doubleMatrix(n_grp, n_covrR);
double **S0o = doubleMatrix(n_covoR, n_covoR);
double **S0r = doubleMatrix(n_covrR, n_covrR);
double **Ao = doubleMatrix(n_covo, n_covo);
double **Ar = doubleMatrix(n_covr, n_covr);
double **mtemp1 = doubleMatrix(n_covo, n_covo);
double **mtemp2 = doubleMatrix(n_covr, n_covr);
/*** QoIs ***/
double *base = doubleArray(n_treat);
double *cATE = doubleArray(n_treat);
/*** storage parameters and loop counters **/
int progress = 1;
int keep = 1;
int i, j, k, main_loop;
int itemp, itemp0, itemp1, itemp2, itemp3 = 0, itempP = ftrunc((double) n_gen/10);
int *vitemp = intArray(n_grp);
double dtemp, pj, r0, r1;
/*** get random seed **/
GetRNGstate();
/*** fixed effects ***/
itemp = 0;
for (j = 0; j < n_covo; j++)
for (i = 0; i < n_samp; i++)
Xo[i][j] = dXo[itemp++];
itemp = 0;
for (j = 0; j < n_covr; j++)
for (i = 0; i < n_samp; i++)
Xr[i][j] = dXr[itemp++];
/* prior */
itemp = 0;
for (k = 0; k < n_covo; k++)
for (j = 0; j < n_covo; j++)
Ao[j][k] = dAo[itemp++];
itemp = 0;
for (k = 0; k < n_covr; k++)
for (j = 0; j < n_covr; j++)
Ar[j][k] = dAr[itemp++];
dcholdc(Ao, n_covo, mtemp1);
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] += mtemp1[i][j]*beta0[j];
Xo[n_samp+i][j] = mtemp1[i][j];
}
}
dcholdc(Ar, n_covr, mtemp2);
for(i = 0; i < n_covr; i++) {
Xr[n_samp+i][n_covr] = 0;
for(j = 0; j < n_covr; j++) {
Xr[n_samp+i][n_covr] += mtemp2[i][j]*delta0[j];
Xr[n_samp+i][j] = mtemp2[i][j];
}
}
/* random effects */
itemp = 0;
for (j = 0; j < n_grp; j++)
vitemp[j] = 0;
for (i = 0; i < n_samp; i++) {
for (j = 0; j < n_covoR; j++)
Zo[grp[i]][vitemp[grp[i]]][j] = dZo[itemp++];
vitemp[grp[i]]++;
}
itemp = 0;
for (j = 0; j < n_grp; j++)
vitemp[j] = 0;
for (i = 0; i < n_samp; i++) {
for (j = 0; j < n_covrR; j++)
Zr[grp[i]][vitemp[grp[i]]][j] = dZr[itemp++];
vitemp[grp[i]]++;
}
/* prior variance for random effects */
itemp = 0;
for (k = 0; k < n_covoR; k++)
for (j = 0; j < n_covoR; j++)
PsiO[j][k] = dPsio[itemp++];
itemp = 0;
for (k = 0; k < n_covrR; k++)
for (j = 0; j < n_covrR; j++)
PsiR[j][k] = dPsir[itemp++];
itemp = 0;
for (k = 0; k < n_covoR; k++)
for (j = 0; j < n_grp; j++)
xiO[j][k] = norm_rand();
itemp = 0;
for (k = 0; k < n_covrR; k++)
for (j = 0; j < n_grp; j++)
xiR[j][k] = norm_rand();
/* hyper prior scale parameter for random effects */
itemp = 0;
for (k = 0; k < n_covoR; k++)
for (j = 0; j < n_covoR; j++)
S0o[j][k] = dS0o[itemp++];
itemp = 0;
for (k = 0; k < n_covrR; k++)
for (j = 0; j < n_covrR; j++)
S0r[j][k] = dS0r[itemp++];
/*** Gibbs Sampler! ***/
itemp = 0; itemp0 = 0; itemp1 = 0; itemp2 = 0;
for(main_loop = 1; main_loop <= n_gen; main_loop++){
/** Response Model: binary Probit **/
bprobitMixedGibbs(R, Xr, Zr, grp, delta, xiR, PsiR, n_samp,
n_covr, n_covrR, n_grp, 0, delta0, Ar, *dfr, S0r,
1);
/** Outcome Model: binary probit **/
bprobitMixedGibbs(Y, Xo, Zr, grp, beta, xiO, PsiO, n_samp, n_covo,
n_covoR, n_grp, 0, beta0, Ao, *dfo, S0o, 1);
/** Imputing the missing data **/
for (j = 0; j < n_grp; j++)
vitemp[j] = 0;
for (i = 0; i < n_samp; i++) {
if (R[i] == 0) {
pj = 0;
r0 = delta[0];
r1 = delta[1];
for (j = 0; j < n_covo; j++)
pj += Xo[i][j]*beta[j];
for (j = 2; j < n_covr; j++) {
r0 += Xr[i][j]*delta[j];
r1 += Xr[i][j]*delta[j];
}
for (j = 0; j < n_covoR; j++)
pj += Zo[grp[i]][vitemp[grp[i]]][j]*xiO[grp[i]][j];
for (j = 0; j < n_covrR; j++) {
r0 += Zr[grp[i]][vitemp[grp[i]]][j]*xiR[grp[i]][j];
r1 += Zr[grp[i]][vitemp[grp[i]]][j]*xiR[grp[i]][j];
}
pj = pnorm(0, pj, 1, 0, 0);
r0 = pnorm(0, r0, 1, 0, 0);
r1 = pnorm(0, r1, 1, 0, 0);
if (unif_rand() < ((1-r1)*pj/((1-r1)*pj+(1-r0)*(1-pj)))) {
Y[i] = 1;
Xr[i][0] = 0;
Xr[i][1] = 1;
} else {
Y[i] = 0;
Xr[i][0] = 1;
Xr[i][1] = 0;
}
}
vitemp[grp[i]]++;
}
/** Compute quantities of interest **/
for (j = 0; j < n_grp; j++)
vitemp[j] = 0;
for (j = 0; j < n_treat; j++)
base[j] = 0;
for (i = 0; i < n_samp; i++) {
dtemp = 0;
for (j = n_treat; j < n_covo; j++)
dtemp += Xo[i][j]*beta[j];
for (j = 0; j < n_covoR; j++)
dtemp += Zo[grp[i]][vitemp[grp[i]]][j]*xiO[grp[i]][j];
for (j = 0; j < n_treat; j++) {
if (*Insample) {
if (Xo[i][j] == 1)
base[j] += (double)Y[i];
else
base[j] += (double)((dtemp+beta[j]+norm_rand()) > 0);
} else
base[j] += pnorm(0, dtemp+beta[j], 1, 0, 0);
}
vitemp[grp[i]]++;
}
for (j = 0; j < n_treat; j++)
base[j] /= (double)n_samp;
/** Storing the results **/
if (main_loop > *iBurnin) {
if (keep == *iKeep) {
for (j = 0; j < (n_treat-1); j++)
ATE[itemp0++] = base[j+1] - base[0];
for (j = 0; j < n_treat; j++)
BASE[itemp++] = base[j];
if (*param) {
for (i = 0; i < n_covo; i++)
coefo[itemp1++] = beta[i];
for (i = 0; i < n_covr; i++)
coefr[itemp2++] = delta[i];
for (i = 0; i < n_covoR; i++)
for (j = i; j < n_covoR; j++)
sPsiO[itemp3++] = PsiO[i][j];
for (i = 0; i < n_covrR; i++)
for (j = i; j < n_covrR; j++)
sPsiR[itemp3++] = PsiR[i][j];
}
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_CheckUserInterrupt();
} /* end of Gibbs sampler */
/** write out the random seed **/
PutRNGstate();
/** freeing memory **/
FreeMatrix(Xr, n_samp+n_covr);
FreeMatrix(Xo, n_samp+n_covo);
Free3DMatrix(Zo, n_grp, *max_samp_grp + n_covoR);
Free3DMatrix(Zr, n_grp, *max_samp_grp + n_covrR);
FreeMatrix(PsiO, n_covoR);
FreeMatrix(PsiR, n_covrR);
FreeMatrix(xiO, n_grp);
FreeMatrix(xiR, n_grp);
FreeMatrix(S0o, n_covoR);
FreeMatrix(S0r, n_covrR);
FreeMatrix(Ao, n_covo);
FreeMatrix(Ar, n_covr);
FreeMatrix(mtemp1, n_covo);
FreeMatrix(mtemp2, n_covr);
free(base);
free(cATE);
free(vitemp);
} /* NIbprobitMixed */
void NIbprobit(int *Y, /* binary outcome variable */
int *R, /* recording indicator for Y */
double *dXo, /* covariates */
double *dXr, /* covariates */
double *beta, /* coefficients */
double *delta, /* coefficients */
int *insamp, /* # of obs */
int *incovo, /* # of covariates */
int *incovr, /* # of covariates */
int *intreat, /* # of treatments */
double *beta0, /* prior mean */
double *delta0, /* prior mean */
double *dAo, /* prior precision */
double *dAr, /* prior precision */
int *Insample, /* insample QoI */
int *param, /* store parameters? */
int *mda, /* marginal data augmentation? */
int *ndraws, /* # of gibbs draws */
int *iBurnin, /* # of burnin */
int *iKeep, /* every ?th draws to keep */
int *verbose,
double *coefo, /* storage for coefficients */
double *coefr, /* storage for coefficients */
double *ATE, /* storage for ATE */
double *BASE /* storage for baseline */
) {
/*** counters ***/
int n_samp = *insamp; /* sample size */
int n_gen = *ndraws; /* number of gibbs draws */
int n_covo = *incovo; /* number of covariates */
int n_covr = *incovr; /* number of covariates */
int n_treat = *intreat; /* number of treatments */
/*** data ***/
/* covariates for the response model */
double **Xr = doubleMatrix(n_samp+n_covr, n_covr+1);
/* covariates for the outcome model */
double **Xo = doubleMatrix(n_samp+n_covo, n_covo+1);
/*** model parameters ***/
double **Ao = doubleMatrix(n_covo, n_covo);
double **Ar = doubleMatrix(n_covr, n_covr);
double **mtemp1 = doubleMatrix(n_covo, n_covo);
double **mtemp2 = doubleMatrix(n_covr, n_covr);
/*** QoIs ***/
double *base = doubleArray(n_treat);
double *cATE = doubleArray(n_treat);
/*** storage parameters and loop counters **/
int progress = 1;
int keep = 1;
int i, j, k, main_loop;
int itemp, itemp0, itemp1, itemp2, itempP = ftrunc((double) n_gen/10);
double dtemp, pj, r0, r1;
/*** get random seed **/
GetRNGstate();
/*** read the data ***/
itemp = 0;
for (j = 0; j < n_covo; j++)
for (i = 0; i < n_samp; i++)
Xo[i][j] = dXo[itemp++];
itemp = 0;
for (j = 0; j < n_covr; j++)
for (i = 0; i < n_samp; i++)
Xr[i][j] = dXr[itemp++];
/*** read the prior and it as additional data points ***/
itemp = 0;
for (k = 0; k < n_covo; k++)
for (j = 0; j < n_covo; j++)
Ao[j][k] = dAo[itemp++];
itemp = 0;
for (k = 0; k < n_covr; k++)
for (j = 0; j < n_covr; j++)
Ar[j][k] = dAr[itemp++];
dcholdc(Ao, n_covo, mtemp1);
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] += mtemp1[i][j]*beta0[j];
Xo[n_samp+i][j] = mtemp1[i][j];
}
}
dcholdc(Ar, n_covr, mtemp2);
for(i = 0; i < n_covr; i++) {
Xr[n_samp+i][n_covr] = 0;
for(j = 0; j < n_covr; j++) {
Xr[n_samp+i][n_covr] += mtemp2[i][j]*delta0[j];
Xr[n_samp+i][j] = mtemp2[i][j];
}
}
/*** Gibbs Sampler! ***/
itemp = 0; itemp0 = 0; itemp1 = 0; itemp2 = 0;
for(main_loop = 1; main_loop <= n_gen; main_loop++){
/** Response Model: binary Probit **/
bprobitGibbs(R, Xr, delta, n_samp, n_covr, 0, delta0, Ar, *mda, 1);
/** Outcome Model: binary probit **/
bprobitGibbs(Y, Xo, beta, n_samp, n_covo, 0, beta0, Ao, *mda, 1);
/** Imputing the missing data **/
for (i = 0; i < n_samp; i++) {
if (R[i] == 0) {
pj = 0;
r0 = delta[0];
r1 = delta[1];
for (j = 0; j < n_covo; j++)
pj += Xo[i][j]*beta[j];
for (j = 2; j < n_covr; j++) {
r0 += Xr[i][j]*delta[j];
r1 += Xr[i][j]*delta[j];
}
pj = pnorm(0, pj, 1, 0, 0);
r0 = pnorm(0, r0, 1, 0, 0);
r1 = pnorm(0, r1, 1, 0, 0);
if (unif_rand() < ((1-r1)*pj/((1-r1)*pj+(1-r0)*(1-pj)))) {
Y[i] = 1;
Xr[i][0] = 0;
Xr[i][1] = 1;
} else {
Y[i] = 0;
Xr[i][0] = 1;
Xr[i][1] = 0;
}
}
}
/** Compute quantities of interest **/
for (j = 0; j < n_treat; j++)
base[j] = 0;
for (i = 0; i < n_samp; i++) {
dtemp = 0;
for (j = n_treat; j < n_covo; j++)
dtemp += Xo[i][j]*beta[j];
for (j = 0; j < n_treat; j++) {
if (*Insample) {
if (Xo[i][j] == 1)
base[j] += (double)Y[i];
else
base[j] += (double)((dtemp+beta[j]+norm_rand()) > 0);
} else
base[j] += pnorm(0, dtemp+beta[j], 1, 0, 0);
}
}
for (j = 0; j < n_treat; j++)
base[j] /= (double)n_samp;
/** Storing the results **/
if (main_loop > *iBurnin) {
if (keep == *iKeep) {
for (j = 0; j < (n_treat-1); j++)
ATE[itemp0++] = base[j+1] - base[0];
for (j = 0; j < n_treat; j++)
BASE[itemp++] = base[j];
if (*param) {
for (i = 0; i < n_covo; i++)
coefo[itemp1++] = beta[i];
for (i = 0; i < n_covr; i++)
coefr[itemp2++] = delta[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_CheckUserInterrupt();
} /* end of Gibbs sampler */
/** write out the random seed **/
PutRNGstate();
/** freeing memory **/
FreeMatrix(Xr, n_samp+n_covr);
FreeMatrix(Xo, n_samp+n_covo);
FreeMatrix(Ao, n_covo);
FreeMatrix(Ar, n_covr);
FreeMatrix(mtemp1, n_covo);
FreeMatrix(mtemp2, n_covr);
free(base);
free(cATE);
} /* NIbprobit */
/* sample W via MH for 2xC table */
void rMH2c(
double *W, /* W */
double *X, /* X_i */
double Y, /* Y_i */
double *minU, /* lower bound for U */
double *maxU, /* upper bound for U */
double *mu, /* mean vector for normal */
double **InvSigma, /* Inverse covariance matrix for normal */
int n_dim, /* dimension of parameters */
int maxit, /* max number of iterations for
rejection sampling */
int reject) /* if 1, use rejection sampling to
draw from the truncated Dirichlet
if 0, use Gibbs sampling
*/
{
int iter = 100; /* number of Gibbs iterations */
int i, j, exceed;
double dens1, dens2, ratio, dtemp;
double *Sample = doubleArray(n_dim);
double *param = doubleArray(n_dim);
double *vtemp = doubleArray(n_dim);
double *vtemp1 = doubleArray(n_dim);
/* set parent Dirichlet parameter to 1 */
for (j = 0; j < n_dim; j++)
param[j] = 1.0;
/* Sample a candidate draw of W from truncated Dirichlet */
if (reject) { /* rejection sampling */
i = 0; exceed = 1;
while (exceed > 0) {
rDirich(vtemp, param, n_dim);
exceed = 0;
for (j = 0; j < n_dim; j++)
if (vtemp[j] > maxU[j] || vtemp[j] < minU[j])
exceed++;
i++;
if (i > maxit)
error("rMH2c: rejection algorithm failed because bounds are too tight.\n increase maxit or use gibbs sampler instead.");
}
}
else { /* gibbs sampler */
for (j = 0; j < n_dim; j++)
vtemp[j] = W[j]*X[j]/Y;
for (i = 0; i < iter; i++) {
dtemp = vtemp[n_dim-1];
for (j = 0; j < n_dim-1; j++) {
dtemp += vtemp[j];
vtemp[j] = runif(fmax2(minU[j], dtemp-maxU[n_dim-1]),
fmin2(maxU[j], dtemp-minU[n_dim-1]));
dtemp -= vtemp[j];
}
vtemp[n_dim-1] = dtemp;
}
}
/* calcualte W and its logit transformation */
for (j = 0; j < n_dim; j++) {
Sample[j] = vtemp[j]*Y/X[j];
vtemp[j] = log(Sample[j])-log(1-Sample[j]);
vtemp1[j] = log(W[j])-log(1-W[j]);
}
/* acceptance ratio */
dens1 = dMVN(vtemp, mu, InvSigma, n_dim, 1);
dens2 = dMVN(vtemp1, mu, InvSigma, n_dim, 1);
for (j=0; j<n_dim; j++) {
dens1 -= (log(Sample[j])+log(1-Sample[j]));
dens2 -= (log(W[j])+log(1-W[j]));
}
ratio=fmin2(1, exp(dens1-dens2));
/* accept */
if (unif_rand() < ratio)
for (j = 0; j < n_dim; j++)
W[j] = Sample[j];
free(Sample);
free(param);
free(vtemp);
free(vtemp1);
}
