示例#1
0
文件: rand.c 项目: nickbloom/MNP
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);
}
示例#2
0
文件: funs.cpp 项目: cran/mpbart
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();

}
示例#3
0
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 */
示例#4
0
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 */
示例#5
0
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 */