Пример #1
0
void migC(double *space, int *occupied , double *sigma, double *lambda , double *tau, double *mig, double *mig_event, int *space_dim, int *space_size, int *length_mig)
{
	int i = 0 , j = 0 , index = 0;

	// Affichage des parametres //

	/*printf("\nspace_dim\n %d\n",*space_dim);
	printf("\nspace_size\n %d\n",*space_size);
	printf("\nspace\n");
	for ( i = 0; i < ((*space_size)*(*space_dim)) ; i++) {
		printf("%lf \t",space[i]);
	}*/
	
	/*printf("\n\noccupied\n");
	for ( i = 0; i < (*space_size) ; i++) {
		printf("%d \t",(occupied[i]));
	} */
	
	/*printf("\n\nsigma\n");
	for ( i = 0; i < (*space_dim) ; i++) {
		printf("%lf \t",(sigma[i]));
	}
	
	printf("\n\nlambda\n");
	printf("%lf",*lambda);

	printf("\n\ntau\n");
	printf("%lf",*tau);
	
	printf("\n\nmig\n");
	for ( i = 0; i < (*length_mig) ; i++) {
		printf("%lf \t",(mig[i]));
	}
	
	printf("\n\nmig_event\n");
	for ( i = 0; i < (4+(*space_dim)) ; i++) {
		printf("%lf \t",(mig_event[i]));
	}*/
	
	// Fonction //
	
	// ##### 1 ##### //
	// initialization departures and destinations //
	long *departures = NULL, *destinations = NULL;
	long length_departures = 0, length_destinations = 0;
	//long length_departures2 = 0;  //-*-
  
	long sum_occupied = 0;
	for (i = 0 ; i < *space_size ; i++) {
		if (occupied[i]>0){
      sum_occupied += 1;
    }
	}
	
	length_departures = sum_occupied ;
	departures = malloc(length_departures * sizeof(long));
	for (i = 0; i < (*space_size); i++) {
		if (occupied[i] > 0 ) {
			//for (j = 0; j < occupied[i]; j++) {
				departures[index] = (i+1);
				index++;	
			//}
		}
	}
	
	// ##### 2 ##### //
	length_destinations = *space_size ; 
  //length_departures2 = *space_size ;//-*-
	destinations = malloc(*space_size * sizeof(long));
  //departures2 = malloc(*space_size * sizeof(long));//-*-
	for (i = 0 ; i < *space_size ; i++) {
  	destinations[i] = (i+1);
		//departures2[i] = (i+1);//-*-
	}
  
	
	/*printf("\n\ndepartures\n");
	for ( i = 0 ; i < length_departures ; i++) {
		printf("[%d] %ld\n", i, departures[i]);
	}
	
	printf("\n\ndestinations\n");
	for ( i = 0 ; i < length_destinations ; i++) {
		printf("[%d] %ld\n", i, destinations[i]);
	} */
	
	// ##### 3 ##### //
	// Distance matrix //
	double *mat_distsL = NULL, *mat_distsl = NULL;
	long dim_mat_dists = length_departures * length_destinations;
  //long dim_mat_dists = length_departures2 * length_destinations;//-*-
	mat_distsL = malloc(dim_mat_dists * sizeof(double));
	mat_distsl = malloc(dim_mat_dists * sizeof(double));
  for (i = 0 ; i < length_departures ; i++) {
	//for (i = 0 ; i < length_departures2 ; i++) {//-*-
		for (j = 0; j < length_destinations ; j++) {
			//mat_distsL[i*length_destinations + j] = fabs(space[departures2[i]-1] - space[destinations[j]-1]);//-*-
			//mat_distsl[i*length_destinations + j] = fabs(space[(*space_size+departures2[i]-1)] - space[(*space_size+destinations[j]-1)]);//-*-
  		//mat_distsL[i*length_destinations + j] = fabs(space[departures[i]-1] - space[destinations[j]-1]);                              // euclidean
			//mat_distsl[i*length_destinations + j] = fabs(space[(*space_size+departures[i]-1)] - space[(*space_size+destinations[j]-1)]);  // euclidean
    	mat_distsL[i*length_destinations + j] = distkm( space[departures[i]-1], space[destinations[j]-1], 
        (space[(*space_size+departures[i]-1)]+space[(*space_size+destinations[j]-1)])/2, (space[(*space_size+departures[i]-1)]+space[(*space_size+destinations[j]-1)])/2 );  // km
			mat_distsl[i*length_destinations + j] = distkm( (space[departures[i]-1]+space[destinations[j]-1])/2, (space[departures[i]-1]+space[destinations[j]-1])/2, 
        space[(*space_size+departures[i]-1)], space[(*space_size+destinations[j]-1)] );  // km
		}
	}

	 /*printf("\n\nmat_distsL\n");
	 for (i = 0; i < dim_mat_dists; i++) {
	 printf("%lf , ",mat_distsL[i]);
	 }
	 printf("\n\nmat_distsl\n");
	 for (i = 0; i < dim_mat_dists; i++) {
	 printf("%lf , ",mat_distsl[i]);
	 }*/
	
	// ##### 4 ##### //
	// Density matrix //
	double mean = 0, sdL, sdl ;
  sdL = sqrt(sigma[0]);
  sdl = sqrt(sigma[1]);
	int b_log = 1;
	double *densitymat= NULL;
	densitymat = malloc(dim_mat_dists * sizeof(double));
	for (i = 0; i < length_destinations; i++) {
  	for (j = 0; j < length_departures; j++) {
		//for (j = 0; j < length_departures2; j++) {//-*-
  		//densitymat[i + (length_destinations * j)] = ((dnorm(mat_distsL[i + (length_destinations * j)] , mean , sdL , b_log)) + (dnorm(mat_distsl[i + (length_destinations * j)] , mean , sdl , b_log))) - ( log((pnorm(1, mean, sdL,1,0)- pnorm(0, mean, sdL,1,0))) + log((pnorm(1,mean,sdl,1,0) - pnorm(0,mean,sdl,1,0)))) ;
			densitymat[i + (length_destinations * j)] = exp( (dnorm(mat_distsL[i + (length_destinations * j)] , mean , sdL , b_log) - dnorm(0 , mean , sdL , b_log)) +
                                                       (dnorm(mat_distsl[i + (length_destinations * j)] , mean , sdl , b_log) - dnorm(0 , mean , sdl , b_log)) )
                                                  / length_destinations ;
		}
	}

	 /*
   if (sum_occupied==1){
     printf("\n\nF_{i,j}\n");
  	 for (i = 0; i < dim_mat_dists ; i++) {
  	   printf("%e , ",densitymat[i]);
  	 }
   } */
	
	// ##### 5 ##### //
  
  /* printf("\n\noccupied\n");
	for ( i = 0; i < (*space_size) ; i++) {
		printf("%lf \t",(double)occupied[i]);
	}*/
  
  //FILE *fp;
  //if (sum_occupied==1){fp = fopen("results.dat", "w");}
	// Lambda //
	double *L = NULL;
	L = malloc(length_destinations * sizeof(double));
	for (i = 0 ; i < length_destinations ; i++) {
		L[i] = (double)occupied[destinations[(i)]-1];
		if (L[i]==0) {
			L[i] = 1;
		} else if (L[i]>0) {
			L[i] = *lambda ;
		}
	}
	/*printf("\n\nL\n");
	for (i = 0; i < length_destinations ; i++) {
	  printf("%lf , ",L[i]);
    //printf("%d , ",occupied[i]);
	} */
	
	// ##### 6 ##### //
	// R //
  double *R= NULL;
  R = malloc(dim_mat_dists * sizeof(double));
  double Rs=0;
  for ( i = 0 ; i < length_departures ; i++ ) {
	//for ( i = 0 ; i < length_departures2 ; i++ ) {//-*-
		for ( j =0 ; j < length_destinations ; j++) {
			densitymat[i*length_destinations+j] = densitymat[i*length_destinations+j] * L[j];
      R[i*length_destinations+j] = densitymat[i*length_destinations+j] * *tau;
      //if (occupied[destinations[(j)]-1]>=1) Rs += (R[i*length_destinations+j] * (double)occupied[destinations[(j)]-1]);
      if (occupied[departures[(i)]-1]>=1) Rs += (R[i*length_destinations+j] * (double)occupied[departures[(i)]-1]);
      //printf("%lf ",R[i*length_destinations+j]);
      //if (sum_occupied==1){fprintf(fp,"%d-%d, %lf, %ld, %d\n",i,j,L[j],destinations[(j)],occupied[destinations[(j)]-1]);}
		}
    //printf("\n");
	}
  //if (sum_occupied==1){fclose(fp);}


   /*
   if (sum_occupied==1){
     printf("\n\nR_{i,j}\n");
  	 for (i = 0; i < dim_mat_dists ; i++) {
  	   printf("%e , ",R[i]);
  	 }
   } */
   
	 /*printf("\n\ndensitymat6\n");
	 for (i = 0; i < dim_mat_dists ; i++) {
	   printf("%lf , ",densitymat[i]);
	 } */
	
	// ##### 7 ##### //
  /*double sumd=0;
	for (i = 0 ; i < dim_mat_dists ; i++) {
		if (IsFiniteNumber(densitymat[i])==0) {
			densitymat[i]=0;
		}
    sumd += densitymat[i];
	}*/
  if (Rs==0) {
    /*printf("\nno possible move\n");
    printf("\n\ndensitymat7\n");
    for (i = 0; i < dim_mat_dists ; i++) {
	     printf("%lf , ",R[i]);
	  }*/
  	mig_event[0] = 0;
		mig_event[1] = 0;
		mig_event[2] = 0;
		mig_event[3] = INFINITY;
		for (i = 0; i < *space_dim ; i++) {
			mig_event[4+i] = 0;
		}
		return;
  }

	 /*printf("\n\ndensitymat7\n");
	 for (i = 0; i < dim_mat_dists ; i++) {
	 printf("%lf , ",densitymat[i]);
	 }*/
   	
	double RowSums = 0;
	double *p = NULL;
  p = malloc(length_departures*sizeof(double));
	for ( i =0 ; i < length_departures ; i++ ) {
		RowSums = 0;
		for ( j = 0 ; j < length_destinations ; j++) {
			RowSums += R[(length_destinations*i)+j];
		}
		p[i] = RowSums/Rs ;
	}
	/*printf("\n\nexp_param\n");
	for ( i = 0 ; i < length_departures ; i++) {
	printf("%lf,",exp_param[i]);
	} */
	
  /*printf("\n\nsum_exp_param\n");
	printf("%lf,",sum_exp_param); */
	
	double proba_event = 0;
	double wait_time = 0 ;
  int lstart = 0 , lgoto = 0 ;
	
	// ##### 18 ##### //
	if ( *length_mig > 1) { // find the migration event: from mig[1] to mig[2] and return its probability
  	for ( i = 0 ; i < length_departures ; i++ ) {
			if ( departures[i]==(long)mig[0]) {
				lstart = i;
//printf("x0=%f",space[departures[i]-1]);
//printf(",y0=%f ",space[(*space_size+departures[i]-1)]);
				break;
			}
		}
		for ( i = 0 ; i < length_destinations ; i++ ) {
			if ( destinations[i]==(long)mig[1]) {
				lgoto = i;
//printf("x1=%f",space[destinations[i]-1]);
//printf(",y1=%f ,",space[(*space_size+destinations[i]-1)]);
				break;
			}
		}
		// ##### 19 ##### //
    if (sum_occupied==1){ //root
      double sum_row=0;
      for ( i = 0 ; i < length_destinations ; i++ ) {
        sum_row += R[(length_destinations*lstart)+i];
      }
		  proba_event = R[(length_destinations*(long)(lstart))+(long)(lgoto)] / sum_row;
    }else{
      proba_event = R[(length_destinations*(long)(lstart))+(long)(lgoto)] * exp(-Rs*mig[2]);
    }
		wait_time = 0;
		/*printf("\n\ndexp_proba\n");
  	printf("%lf",dexp_proba(mig[2],sum_exp_param)); */
//printf("from %f to %f, waiting_time=%f, Rs=%e, proba_event=%e (F_{i,j}=%e,R_{i,j}=%e)\n",mig[0],mig[1],mig[2],Rs,proba_event,densitymat[(length_destinations*(long)(lstart))+(long)(lgoto)],R[(length_destinations*(long)(lstart))+(long)(lgoto)]);
	}
	// ##### 21 ##### //
	else { // sample one migration event
    //double sum_densitymat = 0;
    //for (i = 0; i < dim_mat_dists ; i++) {
    //  sum_densitymat += densitymat[i];
	  //}
    wait_time = rexp_proba(Rs);
		/*printf("\n\nwait_time\n");
		printf("%lf",wait_time);*/
    double sum_p = 0;
  	for ( i = 0 ; i < length_departures ; i++) {
  		sum_p += p[i];
  	}
    
    int *x;
    x = malloc(length_departures*sizeof(int));
  	double *probax;
		probax = malloc(length_departures*sizeof(double));
    for ( i = 0 ; i < length_departures ; i++ ) {
    	x[i] = i;
      probax[i] = p[i]/sum_p;
      //printf("%lf\n",probax[i]);
    }
    lstart = sample_proba(x, probax, length_departures);
    //printf("lstart: %d\n",lstart);
    
    int *y;
    y = malloc(length_destinations*sizeof(int));
    double *probay;
		probay = malloc(length_destinations*sizeof(double));
    double sum_row=0;
    for ( i = 0 ; i < length_destinations ; i++ ) {
      sum_row += R[(length_destinations*lstart)+i];
    }
    //printf("sum_row %lf\n",sum_row);
    for ( i = 0 ; i < length_destinations ; i++ ) {
      y[i] = i;
      probay[i] = R[(length_destinations*lstart)+i]/sum_row;
      //printf("[%d] %lf\n",i,probay[i]);
    }
    lgoto = sample_proba(y, probay, length_destinations);
    /*int *x, event;
  	x = malloc(dim_mat_dists*sizeof(int));
		double *proba;
		proba = malloc(dim_mat_dists * sizeof(double));
    for ( i = 0 ; i < length_departures ; i++ ) {
    	for ( j =0 ; j < length_destinations ; j++) {
  		  x[(length_destinations*i)+j] = (length_destinations*i)+j;
			  proba[(length_destinations*i)+j] = densitymat[(length_destinations*i)+j]/sum_densitymat ; // need proper proba (sum to 1) to call sample_proba()
  		}
  	}*/
		//////////// SAMPLE ///////////////////
  /*printf("\n\nproba\n");
	for ( i = 0 ; i < dim_mat_dists ; i++) {
	printf("%lf,",proba[i]);
	} */
		//event = sample_proba(x, proba, dim_mat_dists);
    //lstart = event/length_destinations;
    //lgoto = event%length_destinations;
    //proba_event = probax[lstart] * probay[lgoto];
  	proba_event = 0 ; //DEBUGGING return the likelihood of the migration event:
    if (sum_occupied==1){ //root
  	  proba_event = R[(length_destinations*(long)(lstart))+(long)(lgoto)] / sum_row;
    }else{
      proba_event = R[(length_destinations*(long)(lstart))+(long)(lgoto)] * exp(-Rs*wait_time);
    }
		free(x);
  	free(y);
		free(probax);
		free(probay);
	}
	/*printf("\n\nlstart \n %d",lstart);
	 printf("\n\nlgoto \n %d",lgoto);
	 printf("\n\nproba_event \n %lf", proba_event);
	 printf("\n\nwait_time \n %lf", wait_time); */
	
	
	// ##### 22 ##### //
	mig_event[0] = departures[(long)(lstart)]  ;
	mig_event[1] = destinations[(long)(lgoto)]  ;
	mig_event[2] = proba_event ;
	mig_event[3] = wait_time ;
	
	for ( i = 0 ; i < *space_dim ; i++) {
		mig_event[4+i] = fabs(space[((*space_size)*i+(destinations[(long)(lgoto)]-1))] - space[((*space_size)*i+(departures[(long)(lstart)]-1))]);
	}
	
	/*printf("\n\nmig_event\n");	
	for ( i = 0 ; i < 6 ; i++) 
	{
	 printf("%lf  ",mig_event[i]);
	 }*/
	
	free(departures);
	free(destinations);
	free(mat_distsL);
	free(mat_distsl);
	free(densitymat);
	free(L);
	free(R);
  free(p);
	
	return;
	
}
Пример #2
0
/* # code for computing a hierarchical model, with normally distributed
   # level 1 errors (variance known) and level 2 follows a DP
   
   # y[i]:      observed datum for obs i
   # theta[i]:  level 1 mean for obs i
   # phi:       vector of unique values of theta (i.e., clusters)
   # config[i]: cluster label / configuration indicator

   ####################################################################
*/
HHRESULT CGaussianMDP::sample_config
(
   int *&config,
   int obs,
   double *sigma2,
   int n,
   double *y,
   double *phi,
   double alpha
)
{
  /*
    # config: vector of configuration indicators
    # obs:    index of observation under study
    # sigma2: (known) level 1 variances(
    # n:      sample size
  */
  
   int i,j,nclus,oldconfig,ind;
   int sumconfig = 0;
   double sumprob;
   double tempphi = 0.0;
   
   HHRESULT hr = HH_OK;
  
   /* get number of configurations/clusters 
      also set up other things to check */
   sumconfig = 0;
   nclus = 0; /* number of configurations */
   for(i=0; i<n; i++)
   {
      if(config[i]==config[obs]) sumconfig++;
      nclus = imax2(config[i], nclus);
   }

   /* ## STEP 1: nothing changes if obs under study (obs) has its own 
         cluster w/prob */
   if( (sumconfig == 1) && (runif(0.0,1.0) < (nclus-1.0)/nclus))
   { 
      goto Cleanup;
   }
  
   
   // nconfig counts obs in clusters, current obs not included

   for(i=0; i<nclus; i++) 
   {      
      nconfig[i] = 0; 
   }
   for(j=0; j<n; j++) 
   {
      nconfig[config[j]-1]++;
   }
   nconfig[config[obs]-1]--; /* #nclus-star */
   
   /* STEP 2: if there are more than 1  obs in case i's cluster, then: */

   if(sumconfig > 1)
   {        
      sumprob = 0;
   
      for(j=0; j<nclus; j++)
      { 
         prob[j] = nconfig[j] *
                   dnorm(y[obs], phi[j], sqrt(sigma2[obs]), 0);
         sumprob += prob[j];
      }
      prob[nclus] = (alpha/(nclus+1)) *
                    dnorm(y[obs], phi[nclus], sqrt(sigma2[obs]), 0); 
      sumprob+=prob[nclus];
      if(sumprob==0)
      { 
         for(j=0; j<=nclus; j++) prob[j]=1.0;
      }

      /* need to add in a sample-type function */
      config[obs] = multinomial(nclus+1,prob);
   
      goto Cleanup;
   }

/* STEP 3: if there is just one obs in cluster but need to sample new clustr:*/
   /*         else  s(i)=1 and need to sample new cluster */
   if(sumconfig==1)  /* # s/b unnec line */
   {
      oldconfig=config[obs];
      for(i=0; i<n; i++)
      {
         if(config[i] > oldconfig) config[i]--;
      }
      config[i]=nclus;

      for(i=1; i<nclus; i++)
      {
         if(i>=oldconfig) 
         {
            nconfig[i-1]=nconfig[i];/* last elt of nconfig now useless */
         }
      }
      
      // shifting the phis down by one, move phi[oldconfig-1] to the end
      if((oldconfig < nclus) && (nclus>1))
      { 
         tempphi = phi[oldconfig-1];
         
         for(i=oldconfig; i<nclus; i++)
         {
            phi[i-1] = phi[i];
         }
         phi[nclus-1] = tempphi;
      }
         
      nclus--;
      sumprob = 0.0;
      for(j=0; j<nclus; j++)
      {
         prob[j] = nconfig[j] * 
                   dnorm(y[obs], phi[j], sqrt(sigma2[obs]), 0);
         sumprob += prob[j];
      }
         
      prob[nclus] = (alpha/(nclus+1)) *
                    dnorm(y[obs], phi[nclus], sqrt(sigma2[obs]), 0);
      sumprob += prob[nclus];
      if(sumprob == 0) 
      {
         for(i=0; i<=nclus; i++) prob[i] = 1.0;
      }
         
      config[obs] = multinomial(nclus+1,prob);
   }
   
Cleanup:
   return hr;
   
Error:
   goto Cleanup;
}
Пример #3
0
void diffhfunc_v(double* u, double* v, int* n, double* param, int* copula, double* out)
{
    int j, k=1;
    double t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, t12, t13, t15, t16, t18, t19, t20, t21, t22, t27, t33;

    double theta = param[0];

    for(j=0;j<*n;j++)
    {
        if(*copula==0)
        {
            out[j]=0;
        }
        else if(*copula==1)
        {
            t1=qnorm(u[j],0.0,1.0,1,0);
            t2=qnorm(v[j],0.0,1.0,1,0);
            t3=t1-theta*t2;
            t4=1.0-pow(theta,2);
            t5=sqrt(t4);
            t6=t3/t5;
            t7=dnorm(t6,0.0,1.0,0);
            t8=sqrt(2.0*pi);
            t9=pow(t2,2);
            t10=exp(-t9/2.0);
            out[j]=t7*t8*(-theta)/t5/t10;
        }
        else if(*copula==2)
        {
            diffhfunc_v_tCopula_new(&u[j], &v[j], &k, param, copula, &out[j]);
        }
        else if(*copula==3)
        {
            t1 = -theta-1.0;
            t2 = pow(v[j],1.0*t1);
            t4 = 1/v[j];
            t5 = pow(u[j],-1.0*theta);
            t6 = pow(v[j],-1.0*theta);
            t7 = t5+t6-1.0;
            t9 = -1.0-1/theta;
            t10 = pow(t7,1.0*t9);
            out[j] = t10*t4*t1*t2-1/t7*t4*theta*t6*t9*t10*t2;
        }
        else if(*copula==4)
        {
            t3 = log(u[j]);
            t4 = pow(-t3,1.0*theta);
            t5 = log(v[j]);
            t6 = pow(-t5,1.0*theta);
            t7 = t4+t6;
            t8 = 1/theta;
            t9 = pow(t7,1.0*t8);
            t10 = t6*t6;
            t12 = v[j]*v[j];
            t13 = 1/t12;
            t15 = t5*t5;
            t16 = 1/t15;
            t18 = t16/t7;
            t19 = exp(-t9);
            t20 = t8-1.0;
            t21 = pow(t7,1.0*t20);
            t22 = t19*t21;
            t27 = theta*t13;
            t33 = t6*t13;
            out[j] = t9*t10*t13*t18*t22-t22*t20*t10*t27*t18-t22*t6*t27*t16+t22*t33/t5+t22*t33*t16;
        }
        else if(*copula==5)
        {
            t1 = exp(theta);
            t2 = theta*u[j];
            t3 = exp(t2);
            t6 = theta*v[j];
            t8 = exp(t6+t2);
            t10 = exp(t6+theta);
            t12 = exp(t2+theta);
            t13 = pow(t8-t10-t12+t1,2.0);
            out[j] = t1*(t3-1.0)/t13*(theta*t8-theta*t10);
        }
        else if(*copula==6)
        {
            t2 = pow(1.0-u[j],1.0*theta);
            t3 = 1.0-v[j];
            t4 = pow(t3,1.0*theta);
            t5 = t2*t4;
            t6 = t2+t4-t5;
            t8 = 1/theta-1.0;
            t9 = pow(t6,1.0*t8);
            t12 = 1/t3;
            t19 = theta-1.0;
            t20 = pow(t3,1.0*t19);
            t22 = 1.0-t2;
            out[j] = t9*t8*(-t4*theta*t12+t5*theta*t12)/t6*t20*t22-t9*t20*t19*t12*t22;
        }
    }

}
Пример #4
0
void VB5_dmeasure (double *__lik, double *__y, double *__x, double *__p, int give_log, int *__obsindex, int *__stateindex, int *__parindex, int *__covindex, int __ncovars, double *__covars, double t)
{
  lik = dnorm(Lobs,L,L_sd,give_log);  
}
Пример #5
0
  SEXP spMisalign(SEXP Y_r, SEXP X_r, SEXP p_r, SEXP n_r, SEXP m_r, SEXP coordsD_r,
		  SEXP betaPrior_r, SEXP betaNorm_r, 
		  SEXP KPrior_r, SEXP KPriorName_r, 
		  SEXP PsiPrior_r, 
		  SEXP nuUnif_r, SEXP phiUnif_r,
		  SEXP phiStarting_r, SEXP AStarting_r, SEXP PsiStarting_r, SEXP nuStarting_r, 
		  SEXP phiTuning_r, SEXP ATuning_r, SEXP PsiTuning_r, SEXP nuTuning_r, 
		  SEXP nugget_r, SEXP covModel_r, SEXP amcmc_r, SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP verbose_r, SEXP nReport_r){

    /*****************************************
                Common variables
    *****************************************/
    int h, i, j, k, l, b, s, ii, jj, kk, info, nProtect= 0;
    char const *lower = "L";
    char const *upper = "U";
    char const *nUnit = "N";
    char const *yUnit = "U";
    char const *ntran = "N";
    char const *ytran = "T";
    char const *rside = "R";
    char const *lside = "L";
    const double one = 1.0;
    const double negOne = -1.0;
    const double zero = 0.0;
    const int incOne = 1;

    /*****************************************
                     Set-up
    *****************************************/
    double *Y = REAL(Y_r);
    double *X = REAL(X_r);
    int *p = INTEGER(p_r);
    int *n = INTEGER(n_r);
    int m = INTEGER(m_r)[0];
    int nLTr = m*(m-1)/2+m;

    int N = 0;
    int P = 0;
    for(i = 0; i < m; i++){
      N += n[i];
      P += p[i];
    }

    int mm = m*m;
    int NN = N*N;
    int NP = N*P;
    int PP = P*P;

    double *coordsD = REAL(coordsD_r);

    std::string covModel = CHAR(STRING_ELT(covModel_r,0));

    //priors
    std::string betaPrior = CHAR(STRING_ELT(betaPrior_r,0));
    double *betaMu = NULL;
    double *betaC = NULL;
    
    if(betaPrior == "normal"){
      betaMu = (double *) R_alloc(P, sizeof(double));
      F77_NAME(dcopy)(&P, REAL(VECTOR_ELT(betaNorm_r, 0)), &incOne, betaMu, &incOne);
      
      betaC = (double *) R_alloc(PP, sizeof(double)); 
      F77_NAME(dcopy)(&PP, REAL(VECTOR_ELT(betaNorm_r, 1)), &incOne, betaC, &incOne);
    }

    double *phiUnif = REAL(phiUnif_r);

    std::string KPriorName = CHAR(STRING_ELT(KPriorName_r,0));
    double KIW_df = 0; double *KIW_S = NULL;
    double *ANormMu = NULL; double *ANormC = NULL;

    if(KPriorName == "IW"){
      KIW_S = (double *) R_alloc(mm, sizeof(double));
      KIW_df = REAL(VECTOR_ELT(KPrior_r, 0))[0]; KIW_S = REAL(VECTOR_ELT(KPrior_r, 1));
    }else{//assume A normal (can add more specifications later)
      ANormMu = (double *) R_alloc(nLTr, sizeof(double));
      ANormC = (double *) R_alloc(nLTr, sizeof(double));
      
      for(i = 0; i < nLTr; i++){
	ANormMu[i] = REAL(VECTOR_ELT(KPrior_r, 0))[i];
	ANormC[i] = REAL(VECTOR_ELT(KPrior_r, 1))[i];
      }
    }

    bool nugget = static_cast<bool>(INTEGER(nugget_r)[0]);
    double *PsiIGa = NULL; double *PsiIGb = NULL;

    if(nugget){
      PsiIGa = (double *) R_alloc(m, sizeof(double));
      PsiIGb = (double *) R_alloc(m, sizeof(double));
      
      for(i = 0; i < m; i++){
	PsiIGa[i] = REAL(VECTOR_ELT(PsiPrior_r, 0))[i];
	PsiIGb[i] = REAL(VECTOR_ELT(PsiPrior_r, 1))[i];
      }
    }
 
    //matern
    double *nuUnif = NULL;
    if(covModel == "matern"){
      nuUnif = REAL(nuUnif_r);
    }

    bool amcmc = static_cast<bool>(INTEGER(amcmc_r)[0]);
    int nBatch = INTEGER(nBatch_r)[0];
    int batchLength = INTEGER(batchLength_r)[0];
    double acceptRate = REAL(acceptRate_r)[0];
    int nSamples = nBatch*batchLength;
    int verbose = INTEGER(verbose_r)[0];
    int nReport = INTEGER(nReport_r)[0];
 
    if(verbose){
      Rprintf("----------------------------------------\n");
      Rprintf("\tGeneral model description\n");
      Rprintf("----------------------------------------\n");
      Rprintf("Model fit with %i outcome variables.\n\n", m);
      Rprintf("Number of observations within each outcome:"); printVec(n, m);
      Rprintf("\nNumber of covariates for each outcome (including intercept if specified):"); printVec(p, m);
      Rprintf("\nTotal number of observations: %i\n\n", N);
      Rprintf("Total number of covariates (including intercept if specified): %i\n\n", P);
      Rprintf("Using the %s spatial correlation model.\n\n", covModel.c_str());
      
      if(amcmc){
	Rprintf("Using adaptive MCMC.\n\n");
	Rprintf("\tNumber of batches %i.\n", nBatch);
	Rprintf("\tBatch length %i.\n", batchLength);
	Rprintf("\ttarget acceptance rate %.5f.\n", acceptRate);
	Rprintf("\n");
      }else{
	Rprintf("Number of MCMC samples %i.\n\n", nSamples);
      }
      
      if(!nugget){
	Rprintf("Psi not included in the model (i.e., no nugget model).\n\n");
      }

      Rprintf("Priors and hyperpriors:\n");
      
      if(betaPrior == "flat"){
	Rprintf("\tbeta flat.\n");
      }else{
	Rprintf("\tbeta normal:\n");
	Rprintf("\tmu:"); printVec(betaMu, P);
	Rprintf("\tcov:\n"); printMtrx(betaC, P, P);
      }
      Rprintf("\n");
      
      if(KPriorName == "IW"){
	Rprintf("\tK IW hyperpriors df=%.5f, S=\n", KIW_df);
	printMtrx(KIW_S, m, m);
      }else{
	Rprintf("\tA Normal hyperpriors\n");
	Rprintf("\t\tparameter\tmean\tvar\n");
	for(j = 0, i = 0; j < m; j++){
	  for(k = j; k < m; k++, i++){
	    Rprintf("\t\tA[%i,%i]\t\t%3.1f\t%1.2f\n", j+1, k+1, ANormMu[i], ANormC[i]);
	  }
	}
      }
      Rprintf("\n"); 
      
      if(nugget){
	Rprintf("\tDiag(Psi) IG hyperpriors\n");
	Rprintf("\t\tparameter\tshape\tscale\n");
	for(j = 0; j < m; j++){
	  Rprintf("\t\tPsi[%i,%i]\t%3.1f\t%1.2f\n", j+1, j+1, PsiIGa[j], PsiIGb[j]);
	}
      }
      Rprintf("\n");  

      Rprintf("\tphi Unif hyperpriors\n");
      Rprintf("\t\tparameter\ta\tb\n");
      for(j = 0; j < m; j++){
	Rprintf("\t\tphi[%i]\t\t%0.5f\t%0.5f\n", j+1, phiUnif[j*2], phiUnif[j*2+1]);
      }
      Rprintf("\n");   
      
      if(covModel == "matern"){
	Rprintf("\tnu Unif hyperpriors\n");
	for(j = 0; j < m; j++){
	  Rprintf("\t\tnu[%i]\t\t%0.5f\t%0.5f\n", j+1, nuUnif[j*2], nuUnif[j*2+1]);
	}
	Rprintf("\n");   
      }
      
    }
 
    /*****************************************
         Set-up MCMC sample matrices etc.
    *****************************************/
    //spatial parameters
    int nParams, AIndx, PsiIndx, phiIndx, nuIndx;

    if(!nugget && covModel != "matern"){
      nParams = nLTr+m;//A, phi
      AIndx = 0; phiIndx = nLTr;
    }else if(nugget && covModel != "matern"){
      nParams = nLTr+m+m;//A, diag(Psi), phi
      AIndx = 0; PsiIndx = nLTr; phiIndx = PsiIndx+m;
    }else if(!nugget && covModel == "matern"){
      nParams = nLTr+2*m;//A, phi, nu
      AIndx = 0; phiIndx = nLTr, nuIndx = phiIndx+m;
    }else{
      nParams = nLTr+3*m;//A, diag(Psi), phi, nu
      AIndx = 0; PsiIndx = nLTr, phiIndx = PsiIndx+m, nuIndx = phiIndx+m;
     }
    
    double *params = (double *) R_alloc(nParams, sizeof(double));

    //starting
    covTrans(REAL(AStarting_r), &params[AIndx], m);

    if(nugget){
      for(i = 0; i < m; i++){
	params[PsiIndx+i] = log(REAL(PsiStarting_r)[i]);
      }   
    }

    for(i = 0; i < m; i++){
      params[phiIndx+i] = logit(REAL(phiStarting_r)[i], phiUnif[i*2], phiUnif[i*2+1]);
      
      if(covModel == "matern"){
    	params[nuIndx+i] = logit(REAL(nuStarting_r)[i], nuUnif[i*2], nuUnif[i*2+1]);
      }
    }

    //tuning and fixed
    double *tuning = (double *) R_alloc(nParams, sizeof(double));
    int *fixed = (int *) R_alloc(nParams, sizeof(int)); zeros(fixed, nParams);

    for(i = 0; i < nLTr; i++){
      tuning[AIndx+i] = REAL(ATuning_r)[i];
      if(tuning[AIndx+i] == 0){
    	fixed[AIndx+i] = 1;
      }
    }
    
    if(nugget){
      for(i = 0; i < m; i++){
	tuning[PsiIndx+i] = REAL(PsiTuning_r)[i];
	if(tuning[PsiIndx+i] == 0){
	  fixed[PsiIndx+i] = 1;
	}
      }	
    }

    for(i = 0; i < m; i++){
      tuning[phiIndx+i] = REAL(phiTuning_r)[i];
      if(tuning[phiIndx+i] == 0){
    	fixed[phiIndx+i] = 1;
      }
      
      if(covModel == "matern"){
    	tuning[nuIndx+i] = REAL(nuTuning_r)[i];
    	if(tuning[nuIndx+i] == 0){
    	  fixed[nuIndx+i] = 1;
    	}
      }
    }

    for(i = 0; i < nParams; i++){
      tuning[i] = log(sqrt(tuning[i]));
    }

    //return stuff  
    SEXP samples_r, accept_r, tuning_r;
    PROTECT(samples_r = allocMatrix(REALSXP, nParams, nSamples)); nProtect++;

    if(amcmc){
      PROTECT(accept_r = allocMatrix(REALSXP, nParams, nBatch)); nProtect++; 
      PROTECT(tuning_r = allocMatrix(REALSXP, nParams, nBatch)); nProtect++;  
    }else{
      PROTECT(accept_r = allocMatrix(REALSXP, 1, nSamples/nReport)); nProtect++; 
    }

    // /*****************************************
    //    Set-up MCMC alg. vars. matrices etc.
    // *****************************************/
    int status=1, batchAccept=0, reportCnt=0;
    double logMHRatio =0, logPostCurrent = R_NegInf, logPostCand = 0, det = 0, paramsjCurrent = 0;
    double Q, logDetK, SKtrace;
    
    double *paramsCurrent = (double *) R_alloc(nParams, sizeof(double));
    double *accept = (double *) R_alloc(nParams, sizeof(double)); zeros(accept, nParams);
    
    double *C = (double *) R_alloc(NN, sizeof(double)); 
    double *K = (double *) R_alloc(mm, sizeof(double));
    double *Psi = (double *) R_alloc(m, sizeof(double));
    double *A = (double *) R_alloc(mm, sizeof(double));
    double *phi = (double *) R_alloc(m, sizeof(double));
    double *nu = (double *) R_alloc(m, sizeof(double));

    int P1 = P+1;
    double *vU = (double *) R_alloc(N*P1, sizeof(double));
    double *z = (double *) R_alloc(N, sizeof(double));
    double *tmp_N = (double *) R_alloc(N, sizeof(double));
    double *tmp_mm = (double *) R_alloc(mm, sizeof(double));
    double *tmp_PP = (double *) R_alloc(PP, sizeof(double));
    double *tmp_P = (double *) R_alloc(P, sizeof(double));
    double *tmp_NN = NULL;
    double *Cbeta = NULL;

    if(betaPrior == "normal"){
      tmp_NN = (double *) R_alloc(NN, sizeof(double));
      Cbeta = (double *) R_alloc(NN, sizeof(double));
      
      F77_NAME(dgemv)(ntran, &N, &P, &negOne, X, &N, betaMu, &incOne, &zero, z, &incOne);
      F77_NAME(daxpy)(&N, &one, Y, &incOne, z, &incOne);

      F77_NAME(dsymm)(rside, lower, &N, &P, &one, betaC, &P, X, &N, &zero, vU, &N);
      F77_NAME(dgemm)(ntran, ytran, &N, &N, &P, &one, vU, &N, X, &N, &zero, tmp_NN, &N);
    }
     
    int sl, sk;

    if(verbose){
      Rprintf("-------------------------------------------------\n");
      Rprintf("\t\tSampling\n");
      Rprintf("-------------------------------------------------\n");
      #ifdef Win32
      R_FlushConsole();
      #endif
    }

    GetRNGstate();
    
    for(b = 0, s = 0; b < nBatch; b++){
      for(i = 0; i < batchLength; i++, s++){
    	for(j = 0; j < nParams; j++){
	  
    	  //propose
    	  if(amcmc){
    	    if(fixed[j] == 1){
    	      paramsjCurrent = params[j];
    	    }else{
    	      paramsjCurrent = params[j];
    	      params[j] = rnorm(paramsjCurrent, exp(tuning[j]));
    	    }
    	  }else{
    	    F77_NAME(dcopy)(&nParams, params, &incOne, paramsCurrent, &incOne);
	    
    	    for(j = 0; j < nParams; j++){
    	      if(fixed[j] == 1){
    		params[j] = params[j];
    	      }else{
    		params[j] = rnorm(params[j], exp(tuning[j]));
    	      }
    	    }
    	  }
	  
    	  //extract and transform
    	  covTransInvExpand(&params[AIndx], A, m);
	  
    	  for(k = 0; k < m; k++){
    	    phi[k] = logitInv(params[phiIndx+k], phiUnif[k*2], phiUnif[k*2+1]);
	    
    	    if(covModel == "matern"){
    	      nu[k] = logitInv(params[nuIndx+k], nuUnif[k*2], nuUnif[k*2+1]);
    	    }	  
    	  }
	  
    	  if(nugget){
	    for(k = 0; k < m; k++){
	      Psi[k] = exp(params[PsiIndx+k]);
	    }
	  }
	  
	  //construct covariance matrix
	  sl = sk = 0;
	  
	  for(k = 0; k < m; k++){
	    sl = 0;
	    for(l = 0; l < m; l++){
	      for(kk = 0; kk < n[k]; kk++){
		for(jj = 0; jj < n[l]; jj++){
		  C[(sl+jj)*N+(sk+kk)] = 0.0;
		  for(ii = 0; ii < m; ii++){
		    C[(sl+jj)*N+(sk+kk)] += A[k+m*ii]*A[l+m*ii]*spCor(coordsD[(sl+jj)*N+(sk+kk)], phi[ii], nu[ii], covModel);
		  }
		}
	      }
	      sl += n[l];
	    }
	    sk += n[k];
	  }
	  
    	  if(nugget){
    	    sl = 0;
	    for(l = 0; l < m; l++){
	      for(k = 0; k < n[l]; k++){
	    	C[(sl+k)*N+(sl+k)] += Psi[l];
	      }
	      sl += n[l];
	    }
    	  }

    	  if(betaPrior == "normal"){    
    	    for(k = 0; k < N; k++){
    	      for(l = k; l < N; l++){
    	    	Cbeta[k*N+l] = C[k*N+l]+tmp_NN[k*N+l];
    	      }
    	    }
	    
    	    det = 0;
    	    F77_NAME(dpotrf)(lower, &N, Cbeta, &N, &info); if(info != 0){error("c++ error: dpotrf failed\n");}
    	    for(k = 0; k < N; k++) det += 2*log(Cbeta[k*N+k]);
	    
    	    F77_NAME(dcopy)(&N, z, &incOne, tmp_N, &incOne);
    	    F77_NAME(dtrsv)(lower, ntran, nUnit, &N, Cbeta, &N, tmp_N, &incOne);//u = L^{-1}(y-X'beta)
	    
    	    Q = pow(F77_NAME(dnrm2)(&N, tmp_N, &incOne),2);
    	  }else{//beta flat
    	    det = 0;
    	    F77_NAME(dpotrf)(lower, &N, C, &N, &info); if(info != 0){error("c++ error: dpotrf failed\n");}
    	    for(k = 0; k < N; k++) det += 2*log(C[k*N+k]);
	    
    	    F77_NAME(dcopy)(&N, Y, &incOne, vU, &incOne);
    	    F77_NAME(dcopy)(&NP, X, &incOne, &vU[N], &incOne);

    	    F77_NAME(dtrsm)(lside, lower, ntran, nUnit, &N, &P1, &one, C, &N, vU, &N);//L^{-1}[v:U] = [y:X]
	    
    	    F77_NAME(dgemm)(ytran, ntran, &P, &P, &N, &one, &vU[N], &N, &vU[N], &N, &zero, tmp_PP, &P); //U'U
    	    F77_NAME(dpotrf)(lower, &P, tmp_PP, &P, &info); if(info != 0){error("c++ error: dpotrf failed\n");}
    	    for(k = 0; k < P; k++) det += 2*log(tmp_PP[k*P+k]);
	    
    	    F77_NAME(dgemv)(ytran, &N, &P, &one, &vU[N], &N, vU, &incOne, &zero, tmp_P, &incOne); //U'v
    	    F77_NAME(dtrsv)(lower, ntran, nUnit, &P, tmp_PP, &P, tmp_P, &incOne);

    	    Q = pow(F77_NAME(dnrm2)(&N, vU, &incOne),2) - pow(F77_NAME(dnrm2)(&P, tmp_P, &incOne),2) ;
    	  }
	  
    	  //
    	  //priors, jacobian adjustments, and likelihood
    	  //
    	  logPostCand = 0.0;
	  
    	  if(KPriorName == "IW"){
    	    logDetK = 0.0;
    	    SKtrace = 0.0;
	    
    	    for(k = 0; k < m; k++){logDetK += 2*log(A[k*m+k]);}
	    
    	    //jacobian \sum_{i=1}^{m} (m-i+1)*log(a_ii)+log(a_ii)
    	    for(k = 0; k < m; k++){logPostCand += (m-k)*log(A[k*m+k])+log(A[k*m+k]);}
	    
    	    //S*K^-1
    	    F77_NAME(dpotri)(lower, &m, A, &m, &info); if(info != 0){error("c++ error: dpotri failed\n");}
    	    F77_NAME(dsymm)(rside, lower, &m, &m, &one, A, &m, KIW_S, &m, &zero, tmp_mm, &m);
    	    for(k = 0; k < m; k++){SKtrace += tmp_mm[k*m+k];}
    	    logPostCand += -0.5*(KIW_df+m+1)*logDetK - 0.5*SKtrace;
    	  }else{	     
    	    for(k = 0; k < nLTr; k++){
    	      logPostCand += dnorm(params[AIndx+k], ANormMu[k], sqrt(ANormC[k]), 1);
    	    }
    	  }
	  
    	  if(nugget){
	    for(k = 0; k < m; k++){
	      logPostCand += -1.0*(1.0+PsiIGa[k])*log(Psi[k])-PsiIGb[k]/Psi[k]+log(Psi[k]);
	    }
	  }
	  
    	  for(k = 0; k < m; k++){
    	    logPostCand += log(phi[k] - phiUnif[k*2]) + log(phiUnif[k*2+1] - phi[k]); 
	    
    	    if(covModel == "matern"){
    	      logPostCand += log(nu[k] - nuUnif[k*2]) + log(nuUnif[k*2+1] - nu[k]);  
    	    }
    	  }
	  
    	  logPostCand += -0.5*det-0.5*Q;
	  
    	  //
    	  //MH accept/reject	
    	  //      
    	  logMHRatio = logPostCand - logPostCurrent;
	  
    	  if(runif(0.0,1.0) <= exp(logMHRatio)){
    	    logPostCurrent = logPostCand;
	    
    	    if(amcmc){
    	      accept[j]++;
    	    }else{
    	      accept[0]++;
    	      batchAccept++;
    	    }
	    
    	  }else{
    	    if(amcmc){
    	      params[j] = paramsjCurrent;
    	    }else{
    	      F77_NAME(dcopy)(&nParams, paramsCurrent, &incOne, params, &incOne);
    	    }
    	  }
	  
    	  if(!amcmc){
    	    break;
    	  }
	}//end params
	
    	/******************************
               Save samples
    	*******************************/
    	F77_NAME(dcopy)(&nParams, params, &incOne, &REAL(samples_r)[s*nParams], &incOne);
	
    	R_CheckUserInterrupt();
      }//end batch
      
      //adjust tuning
      if(amcmc){
    	for(j = 0; j < nParams; j++){
    	  REAL(accept_r)[b*nParams+j] = accept[j]/batchLength;
    	  REAL(tuning_r)[b*nParams+j] = tuning[j];
	  
    	  if(accept[j]/batchLength > acceptRate){
    	    tuning[j] += std::min(0.01, 1.0/sqrt(static_cast<double>(b)));
    	  }else{
    	    tuning[j] -= std::min(0.01, 1.0/sqrt(static_cast<double>(b)));
    	  }
    	  accept[j] = 0.0;
    	}
      }
      
      //report
      if(status == nReport){
	
    	if(verbose){
    	  if(amcmc){
    	    Rprintf("Batch: %i of %i, %3.2f%%\n", b+1, nBatch, 100.0*(b+1)/nBatch);
    	    Rprintf("\tparameter\tacceptance\ttuning\n");
    	    for(j = 0, i = 0; j < m; j++){
    	      for(k = j; k < m; k++, i++){
    		Rprintf("\tA[%i,%i]\t\t%3.1f\t\t%1.2f\n", j+1, k+1, 100.0*REAL(accept_r)[b*nParams+AIndx+i], exp(tuning[AIndx+i]));
    	      }
    	    }
    	    if(nugget){
	      for(j = 0; j < m; j++){
		Rprintf("\tPsi[%i,%i]\t%3.1f\t\t%1.2f\n", j+1, j+1, 100.0*REAL(accept_r)[b*nParams+PsiIndx+j], exp(tuning[PsiIndx+j]));
	      }
	    }
    	    for(j = 0; j < m; j++){
    	      Rprintf("\tphi[%i]\t\t%3.1f\t\t%1.2f\n", j+1, 100.0*REAL(accept_r)[b*nParams+phiIndx+j], exp(tuning[phiIndx+j]));
    	    }
    	    if(covModel == "matern"){
    	      Rprintf("\n");
    	      for(j = 0; j < m; j++){
    		Rprintf("\tnu[%i]\t\t%3.1f\t\t%1.2f\n", j+1, 100.0*REAL(accept_r)[b*nParams+nuIndx+j], exp(tuning[nuIndx+j]));
    	      } 
    	    }
    	  }else{
    	    Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples);
    	    Rprintf("Report interval Metrop. Acceptance rate: %3.2f%%\n", 100.0*batchAccept/nReport);
    	    Rprintf("Overall Metrop. Acceptance rate: %3.2f%%\n", 100.0*accept[0]/s);
    	  }
    	  Rprintf("-------------------------------------------------\n");
          #ifdef Win32
    	  R_FlushConsole();
          #endif
    	}

    	if(!amcmc){
    	  REAL(accept_r)[reportCnt] = 100.0*batchAccept/nReport;
    	  reportCnt++;
    	}
	
    	status = 0;
    	batchAccept = 0;
      }
      status++;
      
    }//end sample loop
    
    PutRNGstate();
    
    //untransform variance variables
    for(s = 0; s < nSamples; s++){
      
      covTransInv(&REAL(samples_r)[s*nParams+AIndx], &REAL(samples_r)[s*nParams+AIndx], m);
      
      if(nugget){
	for(i = 0; i < m; i++){
	  REAL(samples_r)[s*nParams+PsiIndx+i] = exp(REAL(samples_r)[s*nParams+PsiIndx+i]);
	}
      }
      
      for(i = 0; i < m; i++){
    	REAL(samples_r)[s*nParams+phiIndx+i] = logitInv(REAL(samples_r)[s*nParams+phiIndx+i], phiUnif[i*2], phiUnif[i*2+1]);
	
    	if(covModel == "matern"){
    	  REAL(samples_r)[s*nParams+nuIndx+i] = logitInv(REAL(samples_r)[s*nParams+nuIndx+i], nuUnif[i*2], nuUnif[i*2+1]);
    	}
      }
    }
    
    //make return object
    SEXP result_r, resultName_r;  
    int nResultListObjs = 2;

    if(amcmc){
      nResultListObjs++;
    }
    
    PROTECT(result_r = allocVector(VECSXP, nResultListObjs)); nProtect++;
    PROTECT(resultName_r = allocVector(VECSXP, nResultListObjs)); nProtect++;
    
    //samples
    SET_VECTOR_ELT(result_r, 0, samples_r);
    SET_VECTOR_ELT(resultName_r, 0, mkChar("p.theta.samples")); 
    
    SET_VECTOR_ELT(result_r, 1, accept_r);
    SET_VECTOR_ELT(resultName_r, 1, mkChar("acceptance"));
    
    if(amcmc){
      SET_VECTOR_ELT(result_r, 2, tuning_r);
      SET_VECTOR_ELT(resultName_r, 2, mkChar("tuning"));
    }
    
    namesgets(result_r, resultName_r);
    
    //unprotect
    UNPROTECT(nProtect);
   
    return(result_r);
  }
Пример #6
0
void BAFT_LNsurv_update_beta(gsl_vector *yL,
                             gsl_vector *yU,
                             gsl_vector *yU_posinf,
                             gsl_vector *c0,
                             gsl_vector *c0_neginf,
                             gsl_matrix *X,
                             gsl_vector *y,
                             gsl_vector *beta,
                             double beta0,
                             double sigSq,
                             double beta_prop_var,
                             gsl_vector *accept_beta)
{
    int i, j, u;
    double eta, eta_prop, loglh, loglh_prop, logR;
    
    int n = X -> size1;
    int p = X -> size2;
    
    gsl_vector *beta_prop = gsl_vector_calloc(p);
    gsl_vector *xbeta = gsl_vector_calloc(n);
    gsl_vector *xbeta_prop = gsl_vector_calloc(n);
    
    j = (int) runif(0, p);
    
    loglh = 0;
    loglh_prop = 0;
    
    gsl_vector_memcpy(beta_prop, beta);
    gsl_vector_set(beta_prop, j, rnorm(gsl_vector_get(beta, j), sqrt(beta_prop_var)));
    gsl_blas_dgemv(CblasNoTrans, 1, X, beta, 0, xbeta);
    gsl_blas_dgemv(CblasNoTrans, 1, X, beta_prop, 0, xbeta_prop);
    
    for(i=0;i<n;i++)
    {
        eta = beta0 + gsl_vector_get(xbeta, i);
        eta_prop = beta0 + gsl_vector_get(xbeta_prop, i);
        if(gsl_vector_get(c0_neginf, i) == 0)
        {
            loglh += dnorm(gsl_vector_get(y, i), eta, sqrt(sigSq), 1) - pnorm(gsl_vector_get(c0, i), eta, sqrt(sigSq), 0, 1);
            loglh_prop += dnorm(gsl_vector_get(y, i), eta_prop, sqrt(sigSq), 1) - pnorm(gsl_vector_get(c0, i), eta_prop, sqrt(sigSq), 0, 1);
        }else
        {
            loglh += dnorm(gsl_vector_get(y, i), eta, sqrt(sigSq), 1);
            loglh_prop += dnorm(gsl_vector_get(y, i), eta_prop, sqrt(sigSq), 1);
        }
    }
    
    logR = loglh_prop - loglh;
    u = log(runif(0, 1)) < logR;
    if(u == 1)
    {
        gsl_vector_memcpy(beta, beta_prop);
        gsl_vector_set(accept_beta, j, gsl_vector_get(accept_beta, j) + 1);
    }
    
    gsl_vector_free(beta_prop);
    gsl_vector_free(xbeta);
    gsl_vector_free(xbeta_prop);
    return;
}
Пример #7
0
Type dsn(Type x, Type alpha, int give_log=0)
{
	
	if(!give_log) return 2 * dnorm(x,Type(0),Type(1),0) * pnorm(alpha*x);
	else return log(2.0) + log(dnorm(x,Type(0),Type(1),0)) + log(pnorm(alpha*x));
}
Пример #8
0
/* Apply constraint using SHAKE */
static void do_constraint(t_pull *pull, t_mdatoms *md, t_pbc *pbc,
                          rvec *x, rvec *v,
                          gmx_bool bMaster, tensor vir,
                          double dt, double t) 
{

    dvec *r_ij;  /* x[i] com of i in prev. step. Obeys constr. -> r_ij[i] */
    dvec unc_ij; /* xp[i] com of i this step, before constr.   -> unc_ij  */

    dvec *rinew;           /* current 'new' position of group i */
    dvec *rjnew;           /* current 'new' position of group j */
    dvec  ref,vec;
    double d0,inpr;
    double lambda, rm, mass, invdt=0;
    gmx_bool bConverged_all,bConverged=FALSE;
    int niter=0,g,ii,j,m,max_iter=100;
    double q,a,b,c;  /* for solving the quadratic equation, 
                        see Num. Recipes in C ed 2 p. 184 */
    dvec *dr;        /* correction for group i */
    dvec ref_dr;     /* correction for group j */
    dvec f;          /* the pull force */
    dvec tmp,tmp3;
    t_pullgrp *pdyna,*pgrp,*pref;
    
    snew(r_ij,pull->ngrp+1);
    if (PULL_CYL(pull))
    {
        snew(rjnew,pull->ngrp+1);
    }
    else
    {
        snew(rjnew,1);
    }
    snew(dr,pull->ngrp+1);
    snew(rinew,pull->ngrp+1);
    
    /* copy the current unconstrained positions for use in iterations. We 
       iterate until rinew[i] and rjnew[j] obey the constraints. Then
       rinew - pull.x_unc[i] is the correction dr to group i */
    for(g=1; g<1+pull->ngrp; g++)
    {
        copy_dvec(pull->grp[g].xp,rinew[g]);
    }
    if (PULL_CYL(pull))
    {
        for(g=1; g<1+pull->ngrp; g++)
        {
            copy_dvec(pull->dyna[g].xp,rjnew[g]);
        }
    }
    else
    {
        copy_dvec(pull->grp[0].xp,rjnew[0]);
    }
    
    /* Determine the constraint directions from the old positions */
    for(g=1; g<1+pull->ngrp; g++)
    {
        get_pullgrp_dr(pull,pbc,g,t,r_ij[g]);
        /* Store the difference vector at time t for printing */
        copy_dvec(r_ij[g],pull->grp[g].dr);
        if (debug)
        {
            fprintf(debug,"Pull group %d dr %f %f %f\n",
                    g,r_ij[g][XX],r_ij[g][YY],r_ij[g][ZZ]);
        }
        
        if (pull->eGeom == epullgDIR || pull->eGeom == epullgDIRPBC)
        {
            /* Select the component along vec */
            a = 0;
            for(m=0; m<DIM; m++)
            {
                a += pull->grp[g].vec[m]*r_ij[g][m];
            }
            for(m=0; m<DIM; m++)
            {
                r_ij[g][m] = a*pull->grp[g].vec[m];
            }
        }
    }
    
    bConverged_all = FALSE;
    while (!bConverged_all && niter < max_iter)
    {
        bConverged_all = TRUE;

        /* loop over all constraints */
        for(g=1; g<1+pull->ngrp; g++)
        {
            pgrp = &pull->grp[g];
            if (PULL_CYL(pull))
                pref = &pull->dyna[g];
            else
                pref = &pull->grp[0];

            /* Get the current difference vector */
            get_pullgrps_dr(pull,pbc,g,t,rinew[g],rjnew[PULL_CYL(pull) ? g : 0],
                            -1,unc_ij);

            if (pull->eGeom == epullgPOS)
            {
                for(m=0; m<DIM; m++)
                {
                    ref[m] = pgrp->init[m] + pgrp->rate*t*pgrp->vec[m];
                }
            }
            else
            {
                ref[0] = pgrp->init[0] + pgrp->rate*t;
                /* Keep the compiler happy */
                ref[1] = 0;
                ref[2] = 0;
            }
            
            if (debug)
            {
                fprintf(debug,"Pull group %d, iteration %d\n",g,niter);
            }
            
            rm = 1.0/(pull->grp[g].invtm + pref->invtm);
            
            switch (pull->eGeom)
            {
            case epullgDIST:
                if (ref[0] <= 0)
                {
                    gmx_fatal(FARGS,"The pull constraint reference distance for group %d is <= 0 (%f)",g,ref[0]);
                }
                
                a = diprod(r_ij[g],r_ij[g]); 
                b = diprod(unc_ij,r_ij[g])*2;
                c = diprod(unc_ij,unc_ij) - dsqr(ref[0]);
                
                if (b < 0)
                {
                    q = -0.5*(b - sqrt(b*b - 4*a*c));
                    lambda = -q/a;
                }
                else
                {
                    q = -0.5*(b + sqrt(b*b - 4*a*c));
                    lambda = -c/q;
                }
                
                if (debug)
                {
                    fprintf(debug,
                            "Pull ax^2+bx+c=0: a=%e b=%e c=%e lambda=%e\n",
                            a,b,c,lambda);
                }
                
                /* The position corrections dr due to the constraints */
                dsvmul(-lambda*rm*pgrp->invtm, r_ij[g],  dr[g]);
                dsvmul( lambda*rm*pref->invtm, r_ij[g], ref_dr);
                break;
            case epullgDIR:
            case epullgDIRPBC:
            case epullgCYL:
                /* A 1-dimensional constraint along a vector */
                a = 0;
                for(m=0; m<DIM; m++)
                {
                    vec[m] = pgrp->vec[m];
                    a += unc_ij[m]*vec[m];
                }
                /* Select only the component along the vector */
                dsvmul(a,vec,unc_ij);
                lambda = a - ref[0];
                if (debug)
                {
                    fprintf(debug,"Pull inpr %e lambda: %e\n",a,lambda);
                }
                
                /* The position corrections dr due to the constraints */
                dsvmul(-lambda*rm*pull->grp[g].invtm, vec, dr[g]);
                dsvmul( lambda*rm*       pref->invtm, vec,ref_dr);
                break;
            case epullgPOS:
                for(m=0; m<DIM; m++)
                {
                    if (pull->dim[m])
                    {
                        lambda = r_ij[g][m] - ref[m];
                        /* The position corrections dr due to the constraints */
                        dr[g][m]  = -lambda*rm*pull->grp[g].invtm;
                        ref_dr[m] =  lambda*rm*pref->invtm;
                    }
                    else
                    {
                        dr[g][m]  = 0;
                        ref_dr[m] = 0;
                    }
                }
                break;
            }
            
            /* DEBUG */
            if (debug)
            {
                j = (PULL_CYL(pull) ? g : 0);
                get_pullgrps_dr(pull,pbc,g,t,rinew[g],rjnew[j],-1,tmp);
                get_pullgrps_dr(pull,pbc,g,t,dr[g]   ,ref_dr  ,-1,tmp3);
                fprintf(debug,
                        "Pull cur %8.5f %8.5f %8.5f j:%8.5f %8.5f %8.5f d: %8.5f\n",
                        rinew[g][0],rinew[g][1],rinew[g][2], 
                        rjnew[j][0],rjnew[j][1],rjnew[j][2], dnorm(tmp));
                if (pull->eGeom == epullgPOS)
                {
                    fprintf(debug,
                            "Pull ref %8.5f %8.5f %8.5f\n",
                            pgrp->vec[0],pgrp->vec[1],pgrp->vec[2]);
                }
                else
                {
                    fprintf(debug,
                            "Pull ref %8s %8s %8s   %8s %8s %8s d: %8.5f %8.5f %8.5f\n",
                            "","","","","","",ref[0],ref[1],ref[2]);
                }
                fprintf(debug,
                        "Pull cor %8.5f %8.5f %8.5f j:%8.5f %8.5f %8.5f d: %8.5f\n",
                        dr[g][0],dr[g][1],dr[g][2],
                        ref_dr[0],ref_dr[1],ref_dr[2],
                        dnorm(tmp3));
                fprintf(debug,
                        "Pull cor %10.7f %10.7f %10.7f\n",
                        dr[g][0],dr[g][1],dr[g][2]);
            } /* END DEBUG */
            
            /* Update the COMs with dr */
            dvec_inc(rinew[g],                     dr[g]);
            dvec_inc(rjnew[PULL_CYL(pull) ? g : 0],ref_dr);
        }
        
        /* Check if all constraints are fullfilled now */
        for(g=1; g<1+pull->ngrp; g++)
        {
            pgrp = &pull->grp[g];
            
            get_pullgrps_dr(pull,pbc,g,t,rinew[g],rjnew[PULL_CYL(pull) ? g : 0],
                            -1,unc_ij);
            
            switch (pull->eGeom)
            {
            case epullgDIST:
                bConverged = fabs(dnorm(unc_ij) - ref[0]) < pull->constr_tol;
                break;
            case epullgDIR:
            case epullgDIRPBC:
            case epullgCYL:
                for(m=0; m<DIM; m++)
                {
                    vec[m] = pgrp->vec[m];
                }
                inpr = diprod(unc_ij,vec);
                dsvmul(inpr,vec,unc_ij);
                bConverged =
                    fabs(diprod(unc_ij,vec) - ref[0]) < pull->constr_tol;
                break;
            case epullgPOS:
                bConverged = TRUE;
                for(m=0; m<DIM; m++)
                {
                    if (pull->dim[m] && 
                        fabs(unc_ij[m] - ref[m]) >= pull->constr_tol)
                    {
                        bConverged = FALSE;
                    }
                }
                break;
            }
            
            if (!bConverged)
            {
                if (debug)
                {
                    fprintf(debug,"NOT CONVERGED YET: Group %d:"
                            "d_ref = %f %f %f, current d = %f\n",
                            g,ref[0],ref[1],ref[2],dnorm(unc_ij));
                }

                bConverged_all = FALSE;
            }
        }
        
        niter++;
        /* if after all constraints are dealt with and bConverged is still TRUE
           we're finished, if not we do another iteration */
    }
    if (niter > max_iter)
    {
        gmx_fatal(FARGS,"Too many iterations for constraint run: %d",niter);
    }
    
    /* DONE ITERATING, NOW UPDATE COORDINATES AND CALC. CONSTRAINT FORCES */
    
    if (v)
    {
        invdt = 1/dt;
    }
    
    /* update the normal groups */
    for(g=1; g<1+pull->ngrp; g++)
    {
        pgrp = &pull->grp[g];
        /* get the final dr and constraint force for group i */
        dvec_sub(rinew[g],pgrp->xp,dr[g]);
        /* select components of dr */
        for(m=0; m<DIM; m++)
        {
            dr[g][m] *= pull->dim[m];
        }
        dsvmul(1.0/(pgrp->invtm*dt*dt),dr[g],f);
        dvec_inc(pgrp->f,f);
        switch (pull->eGeom)
        {
        case epullgDIST:
            for(m=0; m<DIM; m++)
            {
                pgrp->f_scal += r_ij[g][m]*f[m]/dnorm(r_ij[g]);
            }
            break;
        case epullgDIR:
        case epullgDIRPBC:
        case epullgCYL:
            for(m=0; m<DIM; m++)
            {
                pgrp->f_scal += pgrp->vec[m]*f[m];
            }
            break;
        case epullgPOS:
            break;
        }
        
        if (vir && bMaster) {
            /* Add the pull contribution to the virial */
            for(j=0; j<DIM; j++)
            {
                for(m=0; m<DIM; m++)
                {
                    vir[j][m] -= 0.5*f[j]*r_ij[g][m];
                }
            }
        }
        
        /* update the atom positions */
        copy_dvec(dr[g],tmp);
        for(j=0;j<pgrp->nat_loc;j++)
        {
            ii = pgrp->ind_loc[j];
            if (pgrp->weight_loc)
            {
                dsvmul(pgrp->wscale*pgrp->weight_loc[j],dr[g],tmp); 
            }
            for(m=0; m<DIM; m++)
            {
                x[ii][m] += tmp[m];
            }
            if (v)
            {
                for(m=0; m<DIM; m++)
                {
                    v[ii][m] += invdt*tmp[m];
                }
            }
        }
    }
    
    /* update the reference groups */
    if (PULL_CYL(pull))
    {
        /* update the dynamic reference groups */
        for(g=1; g<1+pull->ngrp; g++)
        {
            pdyna = &pull->dyna[g];
            dvec_sub(rjnew[g],pdyna->xp,ref_dr);
            /* select components of ref_dr */
            for(m=0; m<DIM; m++)
            {
                ref_dr[m] *= pull->dim[m];
            }
            
            for(j=0;j<pdyna->nat_loc;j++)
            {
                /* reset the atoms with dr, weighted by w_i */
                dsvmul(pdyna->wscale*pdyna->weight_loc[j],ref_dr,tmp); 
                ii = pdyna->ind_loc[j];
                for(m=0; m<DIM; m++)
                {
                    x[ii][m] += tmp[m];
                }
                if (v)
                {
                    for(m=0; m<DIM; m++)
                    {
                        v[ii][m] += invdt*tmp[m];
                    }
                }
            }
        }
    }
    else
    {
        pgrp = &pull->grp[0];
        /* update the reference group */
        dvec_sub(rjnew[0],pgrp->xp, ref_dr); 
        /* select components of ref_dr */
        for(m=0;m<DIM;m++)
        {
            ref_dr[m] *= pull->dim[m];
        }
        
        copy_dvec(ref_dr,tmp);
        for(j=0; j<pgrp->nat_loc;j++)
        {
            ii = pgrp->ind_loc[j];
            if (pgrp->weight_loc)
            {
                dsvmul(pgrp->wscale*pgrp->weight_loc[j],ref_dr,tmp); 
            }
            for(m=0; m<DIM; m++)
            {
                x[ii][m] += tmp[m];
            }
            if (v)
            {
                for(m=0; m<DIM; m++)
                {
                    v[ii][m] += invdt*tmp[m];
                }
            }
        }
    }
    
    /* finished! I hope. Give back some memory */
    sfree(r_ij);
    sfree(rinew);
    sfree(rjnew);
    sfree(dr);
}
Пример #9
0
/* Pulling with a harmonic umbrella potential or constant force */
static void do_pull_pot(int ePull,
                        t_pull *pull, t_pbc *pbc, double t, real lambda,
                        real *V, tensor vir, real *dVdl)
{
    int       g,j,m;
    dvec      dev;
    double    ndr,invdr;
    real      k,dkdl;
    t_pullgrp *pgrp;
    
    /* loop over the groups that are being pulled */
    *V    = 0;
    *dVdl = 0;
    for(g=1; g<1+pull->ngrp; g++)
    {
        pgrp = &pull->grp[g];
        get_pullgrp_distance(pull,pbc,g,t,pgrp->dr,dev);
        
        k    = (1.0 - lambda)*pgrp->k + lambda*pgrp->kB;
        dkdl = pgrp->kB - pgrp->k;
        
        switch (pull->eGeom)
        {
        case epullgDIST:
            ndr   = dnorm(pgrp->dr);
            invdr = 1/ndr;
            if (ePull == epullUMBRELLA)
            {
                pgrp->f_scal  =       -k*dev[0];
                *V           += 0.5*   k*dsqr(dev[0]);
                *dVdl        += 0.5*dkdl*dsqr(dev[0]);
            }
            else
            {
                pgrp->f_scal  =   -k;
                *V           +=    k*ndr;
                *dVdl        += dkdl*ndr;
            }
            for(m=0; m<DIM; m++)
            {
                pgrp->f[m]    = pgrp->f_scal*pgrp->dr[m]*invdr;
            }
            break;
        case epullgDIR:
        case epullgDIRPBC:
        case epullgCYL:
            if (ePull == epullUMBRELLA)
            {
                pgrp->f_scal  =       -k*dev[0];
                *V           += 0.5*   k*dsqr(dev[0]);
                *dVdl        += 0.5*dkdl*dsqr(dev[0]);
            }
            else
            {
                ndr = 0;
                for(m=0; m<DIM; m++)
                {
                    ndr += pgrp->vec[m]*pgrp->dr[m];
                }
                pgrp->f_scal  =   -k;
                *V           +=    k*ndr;
                *dVdl        += dkdl*ndr;
            }
            for(m=0; m<DIM; m++)
            {
                pgrp->f[m]    = pgrp->f_scal*pgrp->vec[m];
            }
            break;
        case epullgPOS:
            for(m=0; m<DIM; m++)
            {
                if (ePull == epullUMBRELLA)
                {
                    pgrp->f[m]  =       -k*dev[m];
                    *V         += 0.5*   k*dsqr(dev[m]);
                    *dVdl      += 0.5*dkdl*dsqr(dev[m]);
                }
                else
                {
                    pgrp->f[m]  =   -k*pull->dim[m];
                    *V         +=    k*pgrp->dr[m]*pull->dim[m];
                    *dVdl      += dkdl*pgrp->dr[m]*pull->dim[m];
                }
            }
            break;
        }
        
        if (vir)
        {
            /* Add the pull contribution to the virial */
            for(j=0; j<DIM; j++)
            {
                for(m=0;m<DIM;m++)
                {
                    vir[j][m] -= 0.5*pgrp->f[j]*pgrp->dr[m];
                }
            }
        }
    }
}
Type dlognorm(Type x, Type meanlog, Type sdlog, int give_log=0){
  Type logres = dnorm( log(x), meanlog, sdlog, true) - log(x);
  if(give_log) return logres; else return exp(logres);
}
Пример #11
0
void get_pullgrp_distance(t_pull *pull,t_pbc *pbc,int g,double t,
                          dvec dr,dvec dev)
{
    static gmx_bool bWarned=FALSE; /* TODO: this should be fixed for thread-safety, 
                                  but is fairly benign */
    t_pullgrp *pgrp;
    int       m;
    dvec      ref;
    double    drs,inpr;
    
    pgrp = &pull->grp[g];
    
    get_pullgrp_dr(pull,pbc,g,t,dr);
    
    if (pull->eGeom == epullgPOS)
    {
        for(m=0; m<DIM; m++)
        {
            ref[m] = pgrp->init[m] + pgrp->rate*t*pgrp->vec[m];
        }
    }
    else
    {
        ref[0] = pgrp->init[0] + pgrp->rate*t;
    }
    
    switch (pull->eGeom)
    {
    case epullgDIST:
        /* Pull along the vector between the com's */
        if (ref[0] < 0 && !bWarned)
        {
            fprintf(stderr,"\nPull reference distance for group %d is negative (%f)\n",g,ref[0]);
            bWarned = TRUE;
        }
        drs = dnorm(dr);
        if (drs == 0)
        {
            /* With no vector we can not determine the direction for the force,
             * so we set the force to zero.
             */
            dev[0] = 0;
        }
        else
        {
            /* Determine the deviation */
            dev[0] = drs - ref[0];
        }
        break;
    case epullgDIR:
    case epullgDIRPBC:
    case epullgCYL:
        /* Pull along vec */
        inpr = 0;
        for(m=0; m<DIM; m++)
        {
            inpr += pgrp->vec[m]*dr[m];
        }
        dev[0] = inpr - ref[0];
        break;
    case epullgPOS:
        /* Determine the difference of dr and ref along each dimension */
        for(m=0; m<DIM; m++)
        {
            dev[m] = (dr[m] - ref[m])*pull->dim[m];
        }
        break;
    }
}
Пример #12
0
Type objective_function<Type>::operator() ()
{
  DATA_STRING(distr);
  DATA_INTEGER(n);
  Type ans = 0;

  if (distr == "norm") {
    PARAMETER(mu);
    PARAMETER(sd);
    vector<Type> x = rnorm(n, mu, sd);
    ans -= dnorm(x, mu, sd, true).sum();
  }
  else if (distr == "gamma") {
    PARAMETER(shape);
    PARAMETER(scale);
    vector<Type> x = rgamma(n, shape, scale);
    ans -= dgamma(x, shape, scale, true).sum();
  }
  else if (distr == "pois") {
    PARAMETER(lambda);
    vector<Type> x = rpois(n, lambda);
    ans -= dpois(x, lambda, true).sum();
  }
  else if (distr == "compois") {
    PARAMETER(mode);
    PARAMETER(nu);
    vector<Type> x = rcompois(n, mode, nu);
    ans -= dcompois(x, mode, nu, true).sum();
  }
  else if (distr == "compois2") {
    PARAMETER(mean);
    PARAMETER(nu);
    vector<Type> x = rcompois2(n, mean, nu);
    ans -= dcompois2(x, mean, nu, true).sum();
  }
  else if (distr == "nbinom") {
    PARAMETER(size);
    PARAMETER(prob);
    vector<Type> x = rnbinom(n, size, prob);
    ans -= dnbinom(x, size, prob, true).sum();
  }
  else if (distr == "nbinom2") {
    PARAMETER(mu);
    PARAMETER(var);
    vector<Type> x = rnbinom2(n, mu, var);
    ans -= dnbinom2(x, mu, var, true).sum();
  }
  else if (distr == "exp") {
    PARAMETER(rate);
    vector<Type> x = rexp(n, rate);
    ans -= dexp(x, rate, true).sum();
  }
  else if (distr == "beta") {
    PARAMETER(shape1);
    PARAMETER(shape2);
    vector<Type> x = rbeta(n, shape1, shape2);
    ans -= dbeta(x, shape1, shape2, true).sum();
  }
  else if (distr == "f") {
    PARAMETER(df1);
    PARAMETER(df2);
    vector<Type> x = rf(n, df1, df2);
    ans -= df(x, df1, df2, true).sum();
  }
  else if (distr == "logis") {
    PARAMETER(location);
    PARAMETER(scale);
    vector<Type> x = rlogis(n, location, scale);
    ans -= dlogis(x, location, scale, true).sum();
  }
  else if (distr == "t") {
    PARAMETER(df);
    vector<Type> x = rt(n, df);
    ans -= dt(x, df, true).sum();
  }
  else if (distr == "weibull") {
    PARAMETER(shape);
    PARAMETER(scale);
    vector<Type> x = rweibull(n, shape, scale);
    ans -= dweibull(x, shape, scale, true).sum();
  }
  else if (distr == "AR1") {
    PARAMETER(phi);
    vector<Type> x(n);
    density::AR1(phi).simulate(x);
    ans += density::AR1(phi)(x);
  }
  else if (distr == "ARk") {
    PARAMETER_VECTOR(phi);
    vector<Type> x(n);
    density::ARk(phi).simulate(x);
    ans += density::ARk(phi)(x);
  }
  else if (distr == "MVNORM") {
    PARAMETER(phi);
    matrix<Type> Sigma(5,5);
    for(int i=0; i<Sigma.rows(); i++)
      for(int j=0; j<Sigma.rows(); j++)
        Sigma(i,j) = exp( -phi * abs(i - j) );
    density::MVNORM_t<Type> nldens = density::MVNORM(Sigma);
    for(int i = 0; i<n; i++) {
      vector<Type> x = nldens.simulate();
      ans += nldens(x);
    }
  }
  else if (distr == "SEPARABLE") {
    PARAMETER(phi1);
    PARAMETER_VECTOR(phi2);
    array<Type> x(100, 200);
    SEPARABLE( density::ARk(phi2), density::AR1(phi1) ).simulate(x);
    ans += SEPARABLE( density::ARk(phi2), density::AR1(phi1) )(x);
  }
  else if (distr == "GMRF") {
    PARAMETER(delta);
    matrix<Type> Q0(5, 5);
    Q0 <<
      1,-1, 0, 0, 0,
     -1, 2,-1, 0, 0,
      0,-1, 2,-1, 0,
      0, 0,-1, 2,-1,
      0, 0, 0,-1, 1;
    Q0.diagonal().array() += delta;
    Eigen::SparseMatrix<Type> Q = asSparseMatrix(Q0);
    vector<Type> x(5);
    for(int i = 0; i<n; i++) {
      density::GMRF(Q).simulate(x);
      ans += density::GMRF(Q)(x);
    }
  }
  else if (distr == "SEPARABLE_NESTED") {
    PARAMETER(phi1);
    PARAMETER(phi2);
    PARAMETER(delta);
    matrix<Type> Q0(5, 5);
    Q0 <<
      1,-1, 0, 0, 0,
     -1, 2,-1, 0, 0,
      0,-1, 2,-1, 0,
      0, 0,-1, 2,-1,
      0, 0, 0,-1, 1;
    Q0.diagonal().array() += delta;
    Eigen::SparseMatrix<Type> Q = asSparseMatrix(Q0);
    array<Type> x(5, 6, 7);
    for(int i = 0; i<n; i++) {
      SEPARABLE(density::AR1(phi2),
                SEPARABLE(density::AR1(phi1),
                          density::GMRF(Q) ) ).simulate(x);
      ans += SEPARABLE(density::AR1(phi2),
                       SEPARABLE(density::AR1(phi1),
                                 density::GMRF(Q) ) )(x);
    }
  }
  else error( ("Invalid distribution '" + distr + "'").c_str() );
  return ans;
}
Пример #13
0
double F77_SUB(dnrm)(double *x, double *mu, double *sigma, int *give_log)
{
	return dnorm(*x, *mu, *sigma, *give_log);
}
Type objective_function<Type>::operator() () {
// data:
DATA_MATRIX(x_ij);
DATA_VECTOR(y_i);
DATA_IVECTOR(k_i); // vector of IDs
DATA_INTEGER(n_k); // number of IDs
DATA_INTEGER(n_j); // number of IDs
DATA_VECTOR(b1_cov_re_i); // predictor data for random slope
DATA_VECTOR(sigma1_cov_re_i); // predictor data for random slope
//DATA_VECTOR(sigma2_cov_re_i); // predictor data for random slope

// parameters:
PARAMETER_VECTOR(b_j)
PARAMETER_VECTOR(sigma_j);
PARAMETER(log_b0_sigma);
PARAMETER_VECTOR(b0_k);
PARAMETER(log_b1_sigma);
PARAMETER_VECTOR(b1_k);
PARAMETER(log_sigma0_sigma);
PARAMETER(log_sigma1_sigma);
PARAMETER_VECTOR(sigma0_k);
PARAMETER_VECTOR(sigma1_k);

int n_data = y_i.size(); // get number of data points to loop over

// Linear predictor
vector<Type> linear_predictor_i(n_data);
vector<Type> linear_predictor_sigma_i(n_data);
linear_predictor_i = x_ij*b_j;
linear_predictor_sigma_i = x_ij*sigma_j;

Type nll = 0.0; // initialize negative log likelihood

for(int i = 0; i < n_data; i++){
  nll -= dnorm(
      y_i(i),

      b0_k(k_i(i)) + b1_k(k_i(i)) * b1_cov_re_i(i) +
      linear_predictor_i(i),

      sqrt(exp(
          sigma0_k(k_i(i)) +
          sigma1_k(k_i(i)) * sigma1_cov_re_i(i) +
          linear_predictor_sigma_i(i))),

      true);
}
for(int k = 0; k < n_k; k++){
  nll -= dnorm(b0_k(k), Type(0.0), exp(log_b0_sigma), true);
  nll -= dnorm(b1_k(k), Type(0.0), exp(log_b1_sigma), true);
  nll -= dnorm(sigma0_k(k), Type(0.0), exp(log_sigma0_sigma), true);
  nll -= dnorm(sigma1_k(k), Type(0.0), exp(log_sigma1_sigma), true);
  //nll -= dnorm(sigma2_k(k), Type(0.0), exp(log_sigma2_sigma), true);
}

// Reporting
Type b0_sigma = exp(log_b0_sigma);
Type b1_sigma = exp(log_b1_sigma);
Type sigma0_sigma = exp(log_sigma0_sigma);
Type sigma1_sigma = exp(log_sigma1_sigma);
//Type sigma2_sigma = exp(log_sigma2_sigma);

vector<Type> b1_b1_k(n_k);
vector<Type> sigma1_sigma1_k(n_k);
for(int k = 0; k < n_k; k++){
  // these are fixed-effect slopes + random-effect slopes
  b1_b1_k(k) = b_j(n_j) + b1_k(k);
  sigma1_sigma1_k(k) = sigma_j(n_j) + sigma1_k(k);
}

REPORT( b0_k );
REPORT( b1_k );
REPORT( b_j );
REPORT( sigma0_k );
REPORT( sigma1_k );
//REPORT( sigma2_k );
REPORT(b0_sigma);
REPORT(b1_sigma);
REPORT(sigma0_sigma);
REPORT(sigma1_sigma);
//REPORT(sigma2_sigma);
REPORT(b1_b1_k);
REPORT(sigma1_sigma1_k);

//ADREPORT( b0_k );
//ADREPORT( b1_k );
//ADREPORT( b_j );
//ADREPORT( sigma0_k );
//ADREPORT( sigma1_k );
//ADREPORT( sigma2_k );
//ADREPORT(b0_sigma);
//ADREPORT(b1_sigma);
//ADREPORT(sigma0_sigma);
//ADREPORT(sigma1_sigma);
//ADREPORT(sigma2_sigma);
//ADREPORT(b1_b1_k);
//ADREPORT(sigma1_sigma1_k);

return nll;
}
Пример #15
0
/***** ***************************************************************************************** *****/
void
NMix_PredCondDensCDFMarg(double* dens,
                         double* qdens,
                         int*    err,
                         const int*    calc_dens, 
                         const int*    nquant, 
                         const double* qprob,
                         const int*    icond,  
                         const double* y,  
                         const int*    p,       
                         const int*    n,  
                         const int*    chK,    
                         const double* chw,  
                         const double* chmu,  
                         const double* chLi,
                         const int*    M)
{
  const char *fname = "NMix_PredCondDensCDFMarg";

  *err = 0;  
  if (*p <= 1){ 
    *err = 1;
    error("%s: Dimension must be at least 2.\n", fname);        
  }
  if (*icond < 0 || *icond >= *p){
    *err = 1;
    error("%s: Incorrect index of the margin by which we condition,\n", fname);
  }

  /***** Variables which will (repeatedly) be used *****/
  /***** ========================================= *****/
  int m0, i0, i1, t, i, j;
  double dtmp;
  double csigma;       /* to keep std. deviation of the margin by which we condition        */
  double cov_m0_icond; /* to keep covariance between two margins                            */
  double mu_cond;      /* to keep conditional mean when computing conditional cdf           */
  double sigma_cond;   /* to keep conditional std. deviation when computing conditional cdf */
  double *densP;
  double *dP;  
  double y2[2];        /* to keep 2-component vector of grid values */
  double mu2[2];       /* to keep 2-component vector of means       */
  double Li2[3];       /* to keep lower triangle of 2x2 matrix      */
  double * Li2P;
  const int *n0;
  const int *K;
  const double *w, *mu, *Li;
  const double *ycP, *y0P, *y0start;
  const double *wP    = NULL;
  const double *muP   = NULL;
  const double *LiP   = NULL;

  const int LTp = (*p * (*p + 1))/2;                           /** length of lower triangles of covariance matrices  **/
  const int icdiag = (*icond * (2 * (*p) - (*icond) + 1))/2;   /** index of diagonal element for icond margin        **/

  const int TWO = 2;
  double log_dets[2];
  log_dets[1] = -TWO * M_LN_SQRT_2PI;   

  /***** lgrid:   Total length of the marginal grids (except the grid by which we condition)       *****/
  /***** lcgrid:  Length of the grid of values by which we condition                               *****/
  /***** ycond:   Pointer to the first value by which we condition                                 *****/
  /***** ldens:   Length of the array dens                                                         *****/
  /***** ========================================================================================= *****/
  int lgrid = 0;
  int lcgrid;
  const double *ycond;
  ycond = y;
  n0 = n;
  for (m0 = 0; m0 < *icond; m0++){
    lgrid += *n0;
    ycond += *n0;
    n0++;
  }
  lcgrid = *n0;  
  n0++;
  for (m0 = *icond + 1; m0 < *p; m0++){
    lgrid += *n0;
    n0++;
  }

  int ldens = (lgrid + 1) * lcgrid;

  
  /***** Working array *****/
  /***** ============= *****/
  double *dwork = Calloc(2 + LTp + lcgrid * (2 + lgrid), double);

  double *dwork_dMVN, *Sigma, *dens_denom, *w_fycond, *dens_numer;
  double *SigmaP, *dens_denomP, *w_fycondP, *dens_numerP, *cSigma;
  dwork_dMVN   = dwork;
  Sigma        = dwork + 2;                     /** space to store Sigma_j (LT(p))                                        **/
  dens_denom   = Sigma + LTp;                   /** space to store denominator when computing conditional densities       **/
                                                /** = {sum_{k<K} w_k*f(ycond[i]): i < lcgrid}                             **/
  w_fycond     = dens_denom + lcgrid;           /** space to store {w_k*f(ycond[i]: i < lcgrid)} for fixed k              **/
                                                /** * this is needed when computing conditional cdf's                     **/
  dens_numer   = w_fycond + lcgrid;             /** space to store numerator when computing conditional densities         **/
  /*** REMARK: dens_numer will be sorted in this way:                                                                  ***/
  /***         f(y0|ycond=ycond[0]), ..., f(y0|ycond[last]), ..., f(y[p-1]|ycond[0]), ..., f(y[p-1]|ycond[last])       ***/



  /***** Reset dens, allocate needed space if pointwise quantiles required *****/
  /***** ================================================================= *****/
  AK_Basic::fillArray(dens, 0.0, ldens);
  double *chdens  = NULL;
  double *chdensP = NULL;
  if (*nquant){
    chdens = Calloc(ldens * *M, double);
    chdensP = chdens;
  }


  /***** Pointers to chains *****/
  /***** ================== *****/
  K  = chK;
  w  = chw;
  mu = chmu;
  Li = chLi;


  /***** Loop over sampled values *****/
  /***** ======================== *****/
  for (t = 0; t < *M; t++){                         /** loop t **/

    AK_Basic::fillArray(dens_denom, 0.0, lcgrid);
    AK_Basic::fillArray(dens_numer, 0.0, lgrid * lcgrid);

    /*** Loop over components ***/
    /*** -------------------- ***/
    for (j = 0; j < *K; j++){                         /** loop j **/
  
      /*** Compute Sigma_j, shift Li to the next mixture component at the same time ***/
      /*** ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
      dP = Sigma;
      for (i = 0; i < LTp; i++){
        *dP = *Li;
        dP++;
        Li++;
      }
      F77_CALL(dpptri)("L", p, Sigma, err);
      if (*err) error("%s: Computation of Sigma failed (iteration %d, component %d).\n", fname, t+1, j+1);        

      /*** Standard deviation of the margin by which we condition ***/
      /*** ++++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
      cSigma = Sigma + icdiag;         /* variance of the margin by which we condition */
      csigma = sqrt(*cSigma);

      /*** Mean of the margin by which we condition ***/
      /*** ++++++++++++++++++++++++++++++++++++++++ ***/
      mu2[1] = mu[*icond];             /* mean of the margin by which we condition    */

      /*** Loop over values by which we condition (compute weights for conditional cdf and denominators) ***/
      /*** +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
      w_fycondP   = w_fycond;
      dens_denomP = dens_denom;
      ycP         = ycond;
      for (i1 = 0; i1 < lcgrid; i1++){
        *w_fycondP   = (*w) * dnorm(*ycP, mu2[1], csigma, 0);
        *dens_denomP += *w_fycondP;            
        ycP++;
        w_fycondP++;
        dens_denomP++;
      }
     
      /*** Loop over remaining margins (compute numerators) ***/
      /*** ++++++++++++++++++++++++++++++++++++++++++++++++ ***/
      SigmaP = Sigma;
      dens_numerP = dens_numer;
      y0start = y;
      n0 = n;

      for (m0 = 0; m0 < *p; m0++){
        if (m0 == *icond){ 
          mu++;                       /* go to the mean of the next margin     */
          SigmaP += ((*p) - m0);      /* go to the variance of the next margin */

          y0start += *n0;
          n0++;          
          continue;
        }


        /*** Route for computation of the conditional density  ***/
        /*** ................................................. ***/
        if (*calc_dens){

          /*** Moments of the bivariate distribution of margin m0 and margin icond ***/
          mu2[0] = *mu;                 /* mean of this margin                    */

          Li2P = Li2;
          *Li2P = *SigmaP;                                         /* variance of this margin                                             */
          Li2P++;
          if (m0 < *icond) *Li2P = SigmaP[(*icond - m0)];          /* covariance between this margin and the margin by which we condition */
          else             *Li2P = cSigma[m0 - (*icond)];
          Li2P++;
          *Li2P = *cSigma;                                         /* variance of the margin by which we condition                        */

          /*** Cholesky decomposition of the 2x2 covariance matrix of (margin m0, margin icond) ***/       
          F77_CALL(dpptrf)("L", &TWO, Li2, err);
          if (*err) error("%s: Cholesky decomposition of 2x2 covariance matrix failed.\n", fname);        
          log_dets[0] = -AK_Basic::log_AK(Li2[0]) - AK_Basic::log_AK(Li2[2]);                            /** log(|Sigma|^{-1/2}) **/             

          /*** Loop over values by which we condition ***/      
          ycP = ycond;
          for (i1 = 0; i1 < lcgrid; i1++){

            y2[1] = *ycP;           
  
            /*** Loop over the grid values of margin m0 ***/ 
            y0P = y0start;
            for (i0 = 0; i0 < *n0; i0++){
              y2[0] = *y0P;

              /** Joint (log-)density of (margin m0 = *y0P, margin icond = *ycP) **/
              Dist::ldMVN2(&dtmp, dwork_dMVN, y2, mu2, Li2, log_dets, &TWO);

              /** Add w_k * joint density to dens_numer **/
              *dens_numerP += *w * AK_Basic::exp_AK(dtmp);

              dens_numerP++;
              y0P++;
            }
            ycP++;
          }     /*** end of loop over values by which we condition ***/
        }                     /*** end of if (*com_dens) ***/

        /*** Route for computation of the conditional cdf ***/
        /*** ............................................ ***/
        else{
          
          /*** Conditional standard deviation of distribution (margin m0 | margin icond = whatsever) ***/
          /*** = var(m0) - cov(m0,icond) * var(icond)^{-1} * cov(icond,m0)                           ***/
          if (m0 < *icond) cov_m0_icond = SigmaP[(*icond - m0)];          /* covariance between this margin and the margin by which we condition */
          else             cov_m0_icond = cSigma[m0 - (*icond)];
          sigma_cond = *SigmaP - cov_m0_icond * cov_m0_icond / *cSigma;
          if (sigma_cond < 0) error("%s: Negative conditional variance.\n", fname);
          sigma_cond = sqrt(sigma_cond);

          /*** Loop over values by which we condition ***/      
          ycP       = ycond;
          w_fycondP = w_fycond;
          for (i1 = 0; i1 < lcgrid; i1++){
  
            /*** Loop over the grid values of margin m0 ***/ 
            y0P = y0start;
            for (i0 = 0; i0 < *n0; i0++){

              /** Conditional mean of distribution (margin m0 | margin icond = *ycP) **/
              mu_cond = *mu + cov_m0_icond * (*ycP - mu2[1]) / *cSigma;

              /** Add w_k * marginal density (margin icond = *ycP) * conditional cdf (margin m0 = *y0P | margin icond = *ycP) **/
              /** to dens_numer                                                                                               **/ 
              *dens_numerP += *w_fycondP * pnorm(*y0P, mu_cond, sigma_cond, 1, 0);

              dens_numerP++;
              y0P++;
            }
            ycP++;
            w_fycondP++;
          }     /*** end of loop over values by which we condition ***/          
        }                     /*** end of else (*com_dens) ***/

        mu++;                         /* go to the mean of the next margin      */
        SigmaP += ((*p) - m0);        /* go to the variance of the next margin  */

        y0start += *n0;
        n0++;
      }    /*** end of loop over margins ***/

      w++;
    }    /*** end of loop over components ***/

    
    /*** Compute values of conditional densities/cdf's ***/    
    /*** --------------------------------------------- ***/
    densP = dens;
    dens_denomP = dens_denom;
    dens_numerP = dens_numer;

    if (*nquant){

      /*** Marginal density for the margin by which we condition ***/
      /*** +++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
      for (i1 = 0; i1 < lcgrid; i1++){
        *chdensP = *dens_denomP;
        *densP += *dens_denomP;
        densP++;
        chdensP++;
        dens_denomP++;
      }
    
      /*** Conditional densities/cdf's ***/
      /*** +++++++++++++++++++++++++++ ***/
      n0 = n;
      for (m0 = 0; m0 < *p; m0++){
        if (m0 == *icond){ 
          n0++;
          continue;
        }

        dens_denomP = dens_denom;
        for (i1 = 0; i1 < lcgrid; i1++){
          for (i0 = 0; i0 < *n0; i0++){
            *chdensP = (*dens_numerP) / (*dens_denomP);
            *densP += *chdensP;
            densP++;
            chdensP++;
            dens_numerP++;          
          }
          dens_denomP++;
        }      

        n0++;
      }
    }

    else{

      /*** Marginal density for the margin by which we condition ***/
      /*** +++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
      for (i1 = 0; i1 < lcgrid; i1++){
        *densP += *dens_denomP;
        densP++;
        dens_denomP++;
      }
    
      /*** Conditional densities/cdf's ***/
      /*** +++++++++++++++++++++++++++ ***/
      n0 = n;
      for (m0 = 0; m0 < *p; m0++){
        if (m0 == *icond){ 
          n0++;
          continue;
        }

        dens_denomP = dens_denom;
        for (i1 = 0; i1 < lcgrid; i1++){
          for (i0 = 0; i0 < *n0; i0++){
            *densP += (*dens_numerP) / (*dens_denomP);
            densP++;
            dens_numerP++;          
          }
          dens_denomP++;
        }      

        n0++;
      }
    }
  }   /*** end of loop over sampled values ***/


  /***** Compute MCMC averages *****/
  /***** ===================== *****/
  densP = dens;
  for (i0 = 0; i0 < ldens; i0++){
    *densP /= *M;
    densP++;
  }


  /***** Compute pointwise quantiles *****/
  /***** =========================== *****/
  if (*nquant){
    Stat::Quantile(qdens, chdens, &ldens, M, qprob, nquant);
  }


  /***** Clean *****/
  /***** ===== *****/
  if (*nquant) Free(chdens);
  Free(dwork);

  return;
}
Пример #16
0
void
rnorm_truncated (double *sample,  int *n, double *mu,
		 double *sigma, double *lower, double *upper)
{
 int		k;
 int		change;
 double	a, b;
 double	logt1 = log(0.150), logt2 = log(2.18), t3 = 0.725, t4 = 0.45;
 double	z, tmp, lograt;

 GetRNGstate();

 for (k=0; k<(*n); k++)
 {
   change = 0;
   a = (lower[k] - mu[k])/sigma[k];
   b = (upper[k] - mu[k])/sigma[k];

    // First scenario
    if( (a == R_NegInf) || (b == R_PosInf))
    {
       if(a == R_NegInf)
	{
          change = 1;
	   a = -b;
	   b = R_PosInf;
	}

	// The two possibilities for this scenario
       if(a <= 0.45) z = norm_rs(a, b);
	else z = exp_rs(a, b);
	if(change) z = -z;
    }
    // Second scenario
    else if((a * b) <= 0.0)
    {
       // The two possibilities for this scenario
       if((dnorm(a, 0.0, 1.0, 1) <= logt1) || (dnorm(b, 0.0, 1.0, 1) <= logt1))
	{
          z = norm_rs(a, b);
	}
	else z = unif_rs(a,b);
    }
    // Third scenario
    else
    {
       if(b < 0)
	{
	   tmp = b; b = -a; a = -tmp; change = 1;
	}

	lograt = dnorm(a, 0.0, 1.0, 1) - dnorm(b, 0.0, 1.0, 1);
	if(lograt <= logt2) z = unif_rs(a,b);
	else if((lograt > logt1) && (a < t3)) z = half_norm_rs(a,b);
	else z = exp_rs(a,b);
	if(change) z = -z;
    }

    sample[k] = sigma[k]*z + mu[k];
 }

 PutRNGstate();
}
Пример #17
0
static void init_pull_coord(t_pull_coord *pcrd, int coord_index_for_output,
                            char *dim_buf,
                            const char *origin_buf, const char *vec_buf,
                            warninp_t wi)
{
    int    m;
    dvec   origin, vec;
    char   buf[STRLEN];

    if (pcrd->eType == epullCONSTRAINT && (pcrd->eGeom == epullgCYL ||
                                           pcrd->eGeom == epullgDIRRELATIVE ||
                                           pcrd->eGeom == epullgANGLE ||
                                           pcrd->eGeom == epullgANGLEAXIS ||
                                           pcrd->eGeom == epullgDIHEDRAL))
    {
        gmx_fatal(FARGS, "Pulling of type %s can not be combined with geometry %s. Consider using pull type %s.",
                  epull_names[pcrd->eType],
                  epullg_names[pcrd->eGeom],
                  epull_names[epullUMBRELLA]);
    }

    if (pcrd->eType == epullEXTERNAL)
    {
        if (pcrd->externalPotentialProvider[0] == '\0')
        {
            sprintf(buf, "The use of pull type '%s' for pull coordinate %d requires that the name of the module providing the potential external is set with the option %s%d%s",
                    epull_names[pcrd->eType], coord_index_for_output,
                    "pull-coord", coord_index_for_output, "-potential-provider");
            warning_error(wi, buf);
        }

        if (pcrd->rate != 0)
        {
            sprintf(buf, "The use of pull type '%s' for pull coordinate %d requires that the pull rate is zero",
                    epull_names[pcrd->eType], coord_index_for_output);
            warning_error(wi, buf);
        }

        if (pcrd->eGeom == epullgCYL)
        {
            /* Warn the user of a PBC restriction, caused by the fact that
             * there is no reference value with an external pull potential.
             */
            sprintf(buf, "With pull type '%s' and geometry '%s', the distance component along the cylinder axis between atoms in the cylinder group and the COM of the pull group should be smaller than half the box length",
                    epull_names[pcrd->eType], epullg_names[pcrd->eGeom]);
            warning_note(wi, buf);
        }
    }

    process_pull_dim(dim_buf, pcrd->dim, pcrd);

    string2dvec(origin_buf, origin);
    if (pcrd->group[0] != 0 && dnorm(origin) > 0)
    {
        gmx_fatal(FARGS, "The pull origin can only be set with an absolute reference");
    }

    /* Check the given initial reference value and warn for dangerous values */
    if (pcrd->eGeom == epullgDIST)
    {
        if (pcrd->bStart && pcrd->init < 0)
        {
            sprintf(buf, "The initial reference distance set by pull-coord-init is set to a negative value (%g) with geometry %s while distances need to be non-negative. "
                    "This may work, since you have set pull-coord-start to 'yes' which modifies this value, but only for certain starting distances. "
                    "If this is a mistake you may want to use geometry %s instead.",
                    pcrd->init, EPULLGEOM(pcrd->eGeom), EPULLGEOM(epullgDIR));
            warning(wi, buf);
        }
    }
    else if (pcrd->eGeom == epullgANGLE || pcrd->eGeom == epullgANGLEAXIS)
    {
        if (pcrd->bStart && (pcrd->init < 0 || pcrd->init > 180))
        {
            /* This value of pcrd->init may be ok depending on pcrd->bStart which modifies pcrd->init later on */
            sprintf(buf, "The initial reference angle set by pull-coord-init (%g) is outside of the allowed range [0, 180] degrees for geometry (%s). "
                    "This may work, since you have set pull-coord-start to 'yes' which modifies this value, but only for certain starting angles.",
                    pcrd->init, EPULLGEOM(pcrd->eGeom));
            warning(wi, buf);
        }
    }
    else if (pcrd->eGeom == epullgDIHEDRAL)
    {
        if (pcrd->bStart && (pcrd->init < -180 || pcrd->init > 180))
        {
            sprintf(buf, "The initial reference angle set by pull-coord-init (%g) is outside of the allowed range [-180, 180] degrees for geometry (%s). "
                    "This may work, since you have set pull-coord-start to 'yes' which modifies this value, but only for certain starting angles.",
                    pcrd->init, EPULLGEOM(pcrd->eGeom));
            warning(wi, buf);
        }
    }

    /* Check and set the pull vector */
    clear_dvec(vec);
    string2dvec(vec_buf, vec);

    if (pcrd->eGeom == epullgDIR || pcrd->eGeom == epullgCYL || pcrd->eGeom == epullgDIRPBC || pcrd->eGeom == epullgANGLEAXIS)
    {
        if (dnorm2(vec) == 0)
        {
            gmx_fatal(FARGS, "With pull geometry %s the pull vector can not be 0,0,0",
                      epullg_names[pcrd->eGeom]);
        }
        for (int d = 0; d < DIM; d++)
        {
            if (vec[d] != 0 && pcrd->dim[d] == 0)
            {
                gmx_fatal(FARGS, "pull-coord-vec has non-zero %c-component while pull_dim for the %c-dimension is set to N", 'x'+d, 'x'+d);
            }
        }

        /* Normalize the direction vector */
        dsvmul(1/dnorm(vec), vec, vec);
    }
    else /* This case is for are all the geometries where the pull vector is not used */
    {
        if (dnorm2(vec) > 0)
        {
            sprintf(buf, "A pull vector is given (%g  %g  %g) but will not be used with geometry %s. If you really want to use this "
                    "vector, consider using geometry %s instead.",
                    vec[0], vec[1], vec[2], EPULLGEOM(pcrd->eGeom),
                    pcrd->eGeom == epullgANGLE ? EPULLGEOM(epullgANGLEAXIS) : EPULLGEOM(epullgDIR));
            warning(wi, buf);
        }
    }
    for (m = 0; m < DIM; m++)
    {
        pcrd->origin[m] = origin[m];
        pcrd->vec[m]    = vec[m];
    }
}
Пример #18
0
/* Apply constraint using SHAKE */
static void do_constraint(t_pull *pull, t_pbc *pbc,
                          rvec *x, rvec *v,
                          gmx_bool bMaster, tensor vir,
                          double dt, double t)
{

    dvec      *r_ij;   /* x[i] com of i in prev. step. Obeys constr. -> r_ij[i] */
    dvec       unc_ij; /* xp[i] com of i this step, before constr.   -> unc_ij  */
    dvec      *rnew;  /* current 'new' positions of the groups */
    double    *dr_tot; /* the total update of the coords */
    double     ref;
    dvec       vec;
    double     d0, inpr;
    double     lambda, rm, mass, invdt = 0;
    gmx_bool   bConverged_all, bConverged = FALSE;
    int        niter = 0, g, c, ii, j, m, max_iter = 100;
    double     a;
    dvec       f;          /* the pull force */
    dvec       tmp, tmp3;
    t_pull_group *pdyna, *pgrp0, *pgrp1;
    t_pull_coord *pcrd;

    snew(r_ij,   pull->ncoord);
    snew(dr_tot, pull->ncoord);

    snew(rnew, pull->ngroup);

    /* copy the current unconstrained positions for use in iterations. We
       iterate until rinew[i] and rjnew[j] obey the constraints. Then
       rinew - pull.x_unc[i] is the correction dr to group i */
    for (g = 0; g < pull->ngroup; g++)
    {
        copy_dvec(pull->group[g].xp, rnew[g]);
    }
    if (PULL_CYL(pull))
    {
        /* There is only one pull coordinate and reference group */
        copy_dvec(pull->dyna[0].xp, rnew[pull->coord[0].group[0]]);
    }

    /* Determine the constraint directions from the old positions */
    for (c = 0; c < pull->ncoord; c++)
    {
        get_pull_coord_dr(pull, c, pbc, t, r_ij[c]);
        /* Store the difference vector at time t for printing */
        copy_dvec(r_ij[c], pull->coord[c].dr);
        if (debug)
        {
            fprintf(debug, "Pull coord %d dr %f %f %f\n",
                    c, r_ij[c][XX], r_ij[c][YY], r_ij[c][ZZ]);
        }

        if (pull->eGeom == epullgDIR || pull->eGeom == epullgDIRPBC)
        {
            /* Select the component along vec */
            a = 0;
            for (m = 0; m < DIM; m++)
            {
                a += pull->coord[c].vec[m]*r_ij[c][m];
            }
            for (m = 0; m < DIM; m++)
            {
                r_ij[c][m] = a*pull->coord[c].vec[m];
            }
        }
    }

    bConverged_all = FALSE;
    while (!bConverged_all && niter < max_iter)
    {
        bConverged_all = TRUE;

        /* loop over all constraints */
        for (c = 0; c < pull->ncoord; c++)
        {
            dvec dr0, dr1;

            pcrd  = &pull->coord[c];
            pgrp0 = &pull->group[pcrd->group[0]];
            pgrp1 = &pull->group[pcrd->group[1]];

            /* Get the current difference vector */
            low_get_pull_coord_dr(pull, pcrd, pbc, t,
                                  rnew[pcrd->group[1]],
                                  rnew[pcrd->group[0]],
                                  -1, unc_ij);

            ref = pcrd->init + pcrd->rate*t;

            if (debug)
            {
                fprintf(debug, "Pull coord %d, iteration %d\n", c, niter);
            }

            rm = 1.0/(pgrp0->invtm + pgrp1->invtm);

            switch (pull->eGeom)
            {
                case epullgDIST:
                    if (ref <= 0)
                    {
                        gmx_fatal(FARGS, "The pull constraint reference distance for group %d is <= 0 (%f)", c, ref);
                    }

                    {
                        double q, c_a, c_b, c_c;

                        c_a = diprod(r_ij[c], r_ij[c]);
                        c_b = diprod(unc_ij, r_ij[c])*2;
                        c_c = diprod(unc_ij, unc_ij) - dsqr(ref);

                        if (c_b < 0)
                        {
                            q      = -0.5*(c_b - sqrt(c_b*c_b - 4*c_a*c_c));
                            lambda = -q/c_a;
                        }
                        else
                        {
                            q      = -0.5*(c_b + sqrt(c_b*c_b - 4*c_a*c_c));
                            lambda = -c_c/q;
                        }

                        if (debug)
                        {
                            fprintf(debug,
                                    "Pull ax^2+bx+c=0: a=%e b=%e c=%e lambda=%e\n",
                                    c_a, c_b, c_c, lambda);
                        }
                    }

                    /* The position corrections dr due to the constraints */
                    dsvmul(-lambda*rm*pgrp1->invtm, r_ij[c], dr1);
                    dsvmul( lambda*rm*pgrp0->invtm, r_ij[c], dr0);
                    dr_tot[c] += -lambda*dnorm(r_ij[c]);
                    break;
                case epullgDIR:
                case epullgDIRPBC:
                case epullgCYL:
                    /* A 1-dimensional constraint along a vector */
                    a = 0;
                    for (m = 0; m < DIM; m++)
                    {
                        vec[m] = pcrd->vec[m];
                        a     += unc_ij[m]*vec[m];
                    }
                    /* Select only the component along the vector */
                    dsvmul(a, vec, unc_ij);
                    lambda = a - ref;
                    if (debug)
                    {
                        fprintf(debug, "Pull inpr %e lambda: %e\n", a, lambda);
                    }

                    /* The position corrections dr due to the constraints */
                    dsvmul(-lambda*rm*pgrp1->invtm, vec, dr1);
                    dsvmul( lambda*rm*pgrp0->invtm, vec, dr0);
                    dr_tot[c] += -lambda;
                    break;
            }

            /* DEBUG */
            if (debug)
            {
                int g0, g1;

                g0 = pcrd->group[0];
                g1 = pcrd->group[1];
                low_get_pull_coord_dr(pull, pcrd, pbc, t, rnew[g1], rnew[g0], -1, tmp);
                low_get_pull_coord_dr(pull, pcrd, pbc, t, dr1, dr0, -1, tmp3);
                fprintf(debug,
                        "Pull cur %8.5f %8.5f %8.5f j:%8.5f %8.5f %8.5f d: %8.5f\n",
                        rnew[g0][0], rnew[g0][1], rnew[g0][2],
                        rnew[g1][0], rnew[g1][1], rnew[g1][2], dnorm(tmp));
                fprintf(debug,
                        "Pull ref %8s %8s %8s   %8s %8s %8s d: %8.5f\n",
                        "", "", "", "", "", "", ref);
                fprintf(debug,
                        "Pull cor %8.5f %8.5f %8.5f j:%8.5f %8.5f %8.5f d: %8.5f\n",
                        dr0[0], dr0[1], dr0[2],
                        dr1[0], dr1[1], dr1[2],
                        dnorm(tmp3));
            } /* END DEBUG */

            /* Update the COMs with dr */
            dvec_inc(rnew[pcrd->group[1]], dr1);
            dvec_inc(rnew[pcrd->group[0]], dr0);
        }

        /* Check if all constraints are fullfilled now */
        for (c = 0; c < pull->ncoord; c++)
        {
            pcrd = &pull->coord[c];

            low_get_pull_coord_dr(pull, pcrd, pbc, t,
                                  rnew[pcrd->group[1]],
                                  rnew[pcrd->group[0]],
                                  -1, unc_ij);

            switch (pull->eGeom)
            {
                case epullgDIST:
                    bConverged = fabs(dnorm(unc_ij) - ref) < pull->constr_tol;
                    break;
                case epullgDIR:
                case epullgDIRPBC:
                case epullgCYL:
                    for (m = 0; m < DIM; m++)
                    {
                        vec[m] = pcrd->vec[m];
                    }
                    inpr = diprod(unc_ij, vec);
                    dsvmul(inpr, vec, unc_ij);
                    bConverged =
                        fabs(diprod(unc_ij, vec) - ref) < pull->constr_tol;
                    break;
            }

            if (!bConverged)
            {
                if (debug)
                {
                    fprintf(debug, "NOT CONVERGED YET: Group %d:"
                            "d_ref = %f, current d = %f\n",
                            g, ref, dnorm(unc_ij));
                }

                bConverged_all = FALSE;
            }
        }

        niter++;
        /* if after all constraints are dealt with and bConverged is still TRUE
           we're finished, if not we do another iteration */
    }
    if (niter > max_iter)
    {
        gmx_fatal(FARGS, "Too many iterations for constraint run: %d", niter);
    }

    /* DONE ITERATING, NOW UPDATE COORDINATES AND CALC. CONSTRAINT FORCES */

    if (v)
    {
        invdt = 1/dt;
    }

    /* update atoms in the groups */
    for (g = 0; g < pull->ngroup; g++)
    {
        const t_pull_group *pgrp;
        dvec                dr;

        if (PULL_CYL(pull) && g == pull->coord[0].group[0])
        {
            pgrp = &pull->dyna[0];
        }
        else
        {
            pgrp = &pull->group[g];
        }

        /* get the final constraint displacement dr for group g */
        dvec_sub(rnew[g], pgrp->xp, dr);
        /* select components of dr */
        for (m = 0; m < DIM; m++)
        {
            dr[m] *= pull->dim[m];
        }

        /* update the atom positions */
        copy_dvec(dr, tmp);
        for (j = 0; j < pgrp->nat_loc; j++)
        {
            ii = pgrp->ind_loc[j];
            if (pgrp->weight_loc)
            {
                dsvmul(pgrp->wscale*pgrp->weight_loc[j], dr, tmp);
            }
            for (m = 0; m < DIM; m++)
            {
                x[ii][m] += tmp[m];
            }
            if (v)
            {
                for (m = 0; m < DIM; m++)
                {
                    v[ii][m] += invdt*tmp[m];
                }
            }
        }
    }

    /* calculate the constraint forces, used for output and virial only */
    for (c = 0; c < pull->ncoord; c++)
    {
        pcrd         = &pull->coord[c];
        pcrd->f_scal = dr_tot[c]/((pull->group[pcrd->group[0]].invtm + pull->group[pcrd->group[1]].invtm)*dt*dt);

        if (vir && bMaster)
        {
            double f_invr;

            /* Add the pull contribution to the virial */
            f_invr = pcrd->f_scal/dnorm(r_ij[c]);

            for (j = 0; j < DIM; j++)
            {
                for (m = 0; m < DIM; m++)
                {
                    vir[j][m] -= 0.5*f_invr*r_ij[c][j]*r_ij[c][m];
                }
            }
        }
    }

    /* finished! I hope. Give back some memory */
    sfree(r_ij);
    sfree(dr_tot);
    sfree(rnew);
}
Type dlognorm(Type x, Type meanlog, Type sdlog, int give_log=0){
  //return 1/(sqrt(2*M_PI)*sd)*exp(-.5*pow((x-mean)/sd,2));
  Type logres = dnorm( log(x), meanlog, sdlog, true) - log(x);
  if(give_log) return logres; else return exp(logres);
}
Пример #20
0
/* Pulling with a harmonic umbrella potential or constant force */
static void do_pull_pot(int ePull,
                        t_pull *pull, t_pbc *pbc, double t, real lambda,
                        real *V, tensor vir, real *dVdl)
{
    int           c, j, m;
    double        dev, ndr, invdr;
    real          k, dkdl;
    t_pull_coord *pcrd;

    /* loop over the pull coordinates */
    *V    = 0;
    *dVdl = 0;
    for (c = 0; c < pull->ncoord; c++)
    {
        pcrd = &pull->coord[c];

        get_pull_coord_distance(pull, c, pbc, t, pcrd->dr, &dev);

        k    = (1.0 - lambda)*pcrd->k + lambda*pcrd->kB;
        dkdl = pcrd->kB - pcrd->k;

        switch (pull->eGeom)
        {
            case epullgDIST:
                ndr   = dnorm(pcrd->dr);
                invdr = 1/ndr;
                if (ePull == epullUMBRELLA)
                {
                    pcrd->f_scal  =       -k*dev;
                    *V           += 0.5*   k*dsqr(dev);
                    *dVdl        += 0.5*dkdl*dsqr(dev);
                }
                else
                {
                    pcrd->f_scal  =   -k;
                    *V           +=    k*ndr;
                    *dVdl        += dkdl*ndr;
                }
                for (m = 0; m < DIM; m++)
                {
                    pcrd->f[m]    = pcrd->f_scal*pcrd->dr[m]*invdr;
                }
                break;
            case epullgDIR:
            case epullgDIRPBC:
            case epullgCYL:
                if (ePull == epullUMBRELLA)
                {
                    pcrd->f_scal  =       -k*dev;
                    *V           += 0.5*   k*dsqr(dev);
                    *dVdl        += 0.5*dkdl*dsqr(dev);
                }
                else
                {
                    ndr = 0;
                    for (m = 0; m < DIM; m++)
                    {
                        ndr += pcrd->vec[m]*pcrd->dr[m];
                    }
                    pcrd->f_scal  =   -k;
                    *V           +=    k*ndr;
                    *dVdl        += dkdl*ndr;
                }
                for (m = 0; m < DIM; m++)
                {
                    pcrd->f[m]    = pcrd->f_scal*pcrd->vec[m];
                }
                break;
        }

        if (vir)
        {
            /* Add the pull contribution to the virial */
            for (j = 0; j < DIM; j++)
            {
                for (m = 0; m < DIM; m++)
                {
                    vir[j][m] -= 0.5*pcrd->f[j]*pcrd->dr[m];
                }
            }
        }
    }
}
void dumpExcitations(const Everything& e, const char* filename)
{
	const GridInfo& g = e.gInfo;

	struct excitation
	{	int q,o,u;
		double dE;
		double dreal, dimag, dnorm;
		
		excitation(int q, int o, int u, double dE, double dreal, double dimag, double dnorm): q(q), o(o), u(u), dE(dE), dreal(dreal), dimag(dimag), dnorm(dnorm){};
		
		inline bool operator<(const excitation& other) const {return dE<other.dE;}
		void print(FILE* fp) const { fprintf(fp, "%5i %3i %3i %12.5e %12.5e %12.5e %12.5e\n", q, o, u, dE, dreal, dimag, dnorm); }
	};
	std::vector<excitation> excitations;

	double maxHOMO=-DBL_MAX, minLUMO=DBL_MAX; // maximum (minimum) of all HOMOs (LUMOs) in all qnums
	int maxHOMOq=0, minLUMOq=0, maxHOMOn=0, minLUMOn=0; //Indices and energies for the indirect gap
	
	//Select relevant eigenvals:
	std::vector<diagMatrix> eigsQP;
	if(e.exCorr.orbitalDep && e.dump.count(std::make_pair(DumpFreq_End, DumpOrbitalDep)))
	{	//Search for an eigenvalsQP file:
		string fname = e.dump.getFilename("eigenvalsQP");
		FILE* fp = fopen(fname.c_str(), "r");
		if(fp)
		{	fclose(fp);
			eigsQP.resize(e.eInfo.nStates);
			e.eInfo.read(eigsQP, fname.c_str());
		}
	}
	const std::vector<diagMatrix>& eigs = eigsQP.size() ? eigsQP : e.eVars.Hsub_eigs;
	
	// Integral kernel's for Fermi's golden rule
	ScalarField r0, r1, r2;
	nullToZero(r0, g); 	nullToZero(r1, g); 	nullToZero(r2, g);
	applyFunc_r(g, Moments::rn_pow_x, 0, g.R, 1, vector3<>(0.,0.,0.), r0->data());
	applyFunc_r(g, Moments::rn_pow_x, 1, g.R, 1, vector3<>(0.,0.,0.), r1->data());
	applyFunc_r(g, Moments::rn_pow_x, 2, g.R, 1, vector3<>(0.,0.,0.), r2->data());
	
	//Find and cache all excitations in system (between same qnums)
	bool insufficientBands = false;
	for(int q=e.eInfo.qStart; q<e.eInfo.qStop; q++)
	{	//Find local H**O and check band sufficiency:
		int H**O = e.eInfo.findHOMO(q);
		if(H**O+1>=e.eInfo.nBands) { insufficientBands=true; break; }
		
		//Update global H**O and LUMO of current process:
		if(eigs[q][H**O]   > maxHOMO) { maxHOMOq = q; maxHOMOn = H**O;   maxHOMO = eigs[q][H**O];   }
		if(eigs[q][H**O+1] < minLUMO) { minLUMOq = q; minLUMOn = H**O+1; minLUMO = eigs[q][H**O+1]; }
		
		for(int o=H**O; o>=0; o--)
		{	for(int u=(H**O+1); u<e.eInfo.nBands; u++)
			{	complex x = integral(I(e.eVars.C[q].getColumn(u,0))*r0*I(e.eVars.C[q].getColumn(o,0)));
				complex y = integral(I(e.eVars.C[q].getColumn(u,0))*r1*I(e.eVars.C[q].getColumn(o,0)));
				complex z = integral(I(e.eVars.C[q].getColumn(u,0))*r2*I(e.eVars.C[q].getColumn(o,0)));
				vector3<> dreal(x.real(), y.real(),z.real());
				vector3<> dimag(x.imag(), y.imag(),z.imag());
				vector3<> dnorm(sqrt(x.norm()), sqrt(y.norm()),sqrt(z.norm()));
				double dE = eigs[q][u]-eigs[q][o]; //Excitation energy
				excitations.push_back(excitation(q, o, u, dE, dreal.length_squared(), dimag.length_squared(), dnorm.length_squared()));
			}
		}
	}
	mpiUtil->allReduce(insufficientBands, MPIUtil::ReduceLOr);
	if(insufficientBands)
	{	logPrintf("Insufficient bands to calculate excited states!\n");
		logPrintf("Increase the number of bands (elec-n-bands) and try again!\n");
		return;
	}
	
	//Transmit results to head process:
	if(mpiUtil->isHead())
	{	excitations.reserve(excitations.size() * mpiUtil->nProcesses());
		for(int jProcess=1; jProcess<mpiUtil->nProcesses(); jProcess++)
		{	//Receive data:
			size_t nExcitations; mpiUtil->recv(nExcitations, jProcess, 0);
			std::vector<int> msgInt(4 + nExcitations*3); 
			std::vector<double> msgDbl(2 + nExcitations*4);
			mpiUtil->recv(msgInt.data(), msgInt.size(), jProcess, 1);
			mpiUtil->recv(msgDbl.data(), msgDbl.size(), jProcess, 2);
			//Unpack:
			std::vector<int>::const_iterator intPtr = msgInt.begin();
			std::vector<double>::const_iterator dblPtr = msgDbl.begin();
			//--- globals:
			int j_maxHOMOq = *(intPtr++); int j_maxHOMOn = *(intPtr++); double j_maxHOMO = *(dblPtr++);
			int j_minLUMOq = *(intPtr++); int j_minLUMOn = *(intPtr++); double j_minLUMO = *(dblPtr++);
			if(j_maxHOMO > maxHOMO) { maxHOMOq=j_maxHOMOq; maxHOMOn=j_maxHOMOn; maxHOMO=j_maxHOMO; }
			if(j_minLUMO < minLUMO) { minLUMOq=j_minLUMOq; minLUMOn=j_minLUMOn; minLUMO=j_minLUMO; }
			//--- excitation array:
			for(size_t iExcitation=0; iExcitation<nExcitations; iExcitation++)
			{	int q = *(intPtr++); int o = *(intPtr++); int u = *(intPtr++);
				double dE = *(dblPtr++);
				double dreal = *(dblPtr++); double dimag = *(dblPtr++); double dnorm = *(dblPtr++);
				excitations.push_back(excitation(q, o, u, dE, dreal, dimag, dnorm));
			}
		}
	}
	else
	{	//Pack data:
		std::vector<int> msgInt; std::vector<double> msgDbl;
		size_t nExcitations = excitations.size();
		msgInt.reserve(4 + nExcitations*3);
		msgDbl.reserve(2 + nExcitations*4);
		msgInt.push_back(maxHOMOq); msgInt.push_back(maxHOMOn); msgDbl.push_back(maxHOMO);
		msgInt.push_back(minLUMOq); msgInt.push_back(minLUMOn); msgDbl.push_back(minLUMO);
		for(const excitation& e: excitations)
		{	msgInt.push_back(e.q); msgInt.push_back(e.o); msgInt.push_back(e.u);
			msgDbl.push_back(e.dE);
			msgDbl.push_back(e.dreal); msgDbl.push_back(e.dimag); msgDbl.push_back(e.dnorm);
		}
		//Send data:
		mpiUtil->send(nExcitations, 0, 0);
		mpiUtil->send(msgInt.data(), msgInt.size(), 0, 1);
		mpiUtil->send(msgDbl.data(), msgDbl.size(), 0, 2);
	}

	//Process and print excitations:
	if(!mpiUtil->isHead()) return;
	
	FILE* fp = fopen(filename, "w");
	if(!fp) die("Error opening %s for writing.\n", filename);
	
	std::sort(excitations.begin(), excitations.end());
	const excitation& opt = excitations.front();
	fprintf(fp, "Using %s eigenvalues.      H**O: %.5f   LUMO: %.5f  \n", eigsQP.size() ? "discontinuity-corrected QP" : "KS", maxHOMO, minLUMO);
	fprintf(fp, "Optical (direct) gap: %.5e (from n = %i to %i in qnum = %i)\n", opt.dE, opt.o, opt.u, opt.q);
	fprintf(fp, "Indirect gap: %.5e (from (%i, %i) to (%i, %i))\n\n", minLUMO-maxHOMO, maxHOMOq, maxHOMOn, minLUMOq, minLUMOn);
	
	fprintf(fp, "Optical excitation energies and corresponding electric dipole transition strengths\n");
	fprintf(fp, "qnum   i   f      dE        |<psi1|r|psi2>|^2 (real, imag, norm)\n");
	for(const excitation& e: excitations) e.print(fp);
	fclose(fp);
}
Пример #22
0
void scantwo_em_estep(int n_ind, int n_gen1, int n_gen2, 
		      double ***Probs, double ***Wts12, 
		      double **Wts1, double **Wts2,
		      double **Addcov, int n_addcov, double **Intcov,
		      int n_intcov, double *pheno, double *weights, 
		      double *param, int full_model, int rescale,
		      int n_col2drop, int *allcol2drop)
{
  int i, j, k1, k2, s, ss;
  double temp;

  for(i=0; i<n_ind; i++) {

    /* Get fitted values and put in Wts12 */
    /* additive covar effect */
    if(n_col2drop) {
      for(ss=0, s=0; ss<n_gen1+n_gen2-1; ss++)
	if(!allcol2drop[ss]) s++;
    }
    else s=n_gen1+n_gen2-1;

    temp = 0.0;
    for(j=0; j<n_addcov; j++, s++) 
      temp += (Addcov[j][i]*param[s]);
    
    /* QTL 1 effect */
    for(k1=0, ss=0, s=0; k1<n_gen1; k1++, ss++, s++) { 
      if(!n_col2drop || !allcol2drop[ss]) {
	for(k2=0; k2<n_gen2; k2++) 
	  Wts12[k1][k2][i] = param[s]*weights[i]+temp;
      }
      else s--;
    }

    /* QTL 2 effect */
    for(k2=0; k2<n_gen2-1; k2++, ss++, s++) { 
      if(!n_col2drop || !allcol2drop[ss]) {
	for(k1=0; k1<n_gen1; k1++) 
	  Wts12[k1][k2][i] += param[s]*weights[i];
      }
      else s--;
    }
    s += n_addcov;
    ss += n_addcov;

    /* QTL x interactive covar */
    for(j=0; j<n_intcov; j++) {
      for(k1=0; k1<n_gen1-1; k1++, ss++, s++) { /* QTL1 x intxn */
	if(!n_col2drop || !allcol2drop[ss]) {
	  for(k2=0; k2<n_gen2; k2++)
	    Wts12[k1][k2][i] += param[s]*Intcov[j][i];
	}
	else s--;
      }
      for(k2=0; k2<n_gen2-1; k2++, ss++, s++) { /* QTL2 x intxn */
	if(!n_col2drop || !allcol2drop[ss]) {
	  for(k1=0; k1<n_gen1; k1++)
	    Wts12[k1][k2][i] += param[s]*Intcov[j][i];
	}
	else s--;
      }
    }
      
    if(full_model) {
      /* QTL x QTL interaction */
      for(k1=0; k1<n_gen1-1; k1++) 
	for(k2=0; k2<n_gen2-1; k2++, ss++, s++) {
	  if(!n_col2drop || !allcol2drop[ss]) 
	    Wts12[k1][k2][i] += param[s]*weights[i];
	  else s--;
	}
      
      /* QTL x QTL x interactive covar */
      for(j=0; j<n_intcov; j++) {
	for(k1=0; k1<n_gen1-1; k1++) {
	  for(k2=0; k2<n_gen2-1; k2++, ss++, s++) {
	    if(!n_col2drop || !allcol2drop[ss]) 
	      Wts12[k1][k2][i] += param[s]*Intcov[j][i];
	    else s--;
	  }
	}
      }
    } 
    /* done calculating fitted values */
    /* s should now be at the location of the residual SD */

    /* calculate p(y|fitted,SD) for normal model 
       and multiple by Genoprob */
    temp=0.0;
    for(k1=0; k1<n_gen1; k1++) 
      for(k2=0; k2<n_gen2; k2++) 
	temp += 
	  (Wts12[k1][k2][i] = (dnorm(pheno[i],Wts12[k1][k2][i],param[s],0)*
			Probs[k1][k2][i]));
    
    /* rescale wts */
    if(rescale) {
      for(k1=0; k1<n_gen1; k1++) 
	for(k2=0; k2<n_gen2; k2++) 
	  Wts12[k1][k2][i] /= temp;

      /* marginal wts */
      for(k1=0; k1<n_gen1; k1++) {
	Wts1[k1][i] = 0.0;
	for(k2=0; k2<n_gen2; k2++)
	  Wts1[k1][i] += Wts12[k1][k2][i];
      }
      for(k2=0; k2<n_gen2; k2++) {
	Wts2[k2][i] = 0.0;
	for(k1=0; k1<n_gen1; k1++)
	  Wts2[k2][i] += Wts12[k1][k2][i];
      }
    } /* end rescale */
      
  } /* end loop over individuals */

}
Пример #23
0
/*
 * Asymptotic expansion to calculate the probability that Poisson variate
 * has value <= x.
 * Various assertions about this are made (without proof) at
 * http://members.aol.com/iandjmsmith/PoissonApprox.htm
 */
static double
ppois_asymp (double x, double lambda, int lower_tail, int log_p)
{
    static const double coefs_a[8] = {
	-1e99, /* placeholder used for 1-indexing */
	2/3.,
	-4/135.,
	8/2835.,
	16/8505.,
	-8992/12629925.,
	-334144/492567075.,
	698752/1477701225.
    };

    static const double coefs_b[8] = {
	-1e99, /* placeholder */
	1/12.,
	1/288.,
	-139/51840.,
	-571/2488320.,
	163879/209018880.,
	5246819/75246796800.,
	-534703531/902961561600.
    };

    double elfb, elfb_term;
    double res12, res1_term, res1_ig, res2_term, res2_ig;
    double dfm, pt_, s2pt, f, np;
    int i;

    dfm = lambda - x;
    /* If lambda is large, the distribution is highly concentrated
       about lambda.  So representation error in x or lambda can lead
       to arbitrarily large values of pt_ and hence divergence of the
       coefficients of this approximation.
    */
    pt_ = - log1pmx (dfm / x);
    s2pt = sqrt (2 * x * pt_);
    if (dfm < 0) s2pt = -s2pt;

    res12 = 0;
    res1_ig = res1_term = sqrt (x);
    res2_ig = res2_term = s2pt;
    for (i = 1; i < 8; i++) {
	res12 += res1_ig * coefs_a[i];
	res12 += res2_ig * coefs_b[i];
	res1_term *= pt_ / i ;
	res2_term *= 2 * pt_ / (2 * i + 1);
	res1_ig = res1_ig / x + res1_term;
	res2_ig = res2_ig / x + res2_term;
    }

    elfb = x;
    elfb_term = 1;
    for (i = 1; i < 8; i++) {
	elfb += elfb_term * coefs_b[i];
	elfb_term /= x;
    }
    if (!lower_tail) elfb = -elfb;
#ifdef DEBUG_p
    REprintf ("res12 = %.14g   elfb=%.14g\n", elfb, res12);
#endif

    f = res12 / elfb;

    np = pnorm (s2pt, 0.0, 1.0, !lower_tail, log_p);

    if (log_p) {
	double n_d_over_p = dpnorm (s2pt, !lower_tail, np);
#ifdef DEBUG_p
	REprintf ("pp*_asymp(): f=%.14g	 np=e^%.14g  nd/np=%.14g  f*nd/np=%.14g\n",
		  f, np, n_d_over_p, f * n_d_over_p);
#endif
	return np + log1p (f * n_d_over_p);
    } else {
	double nd = dnorm (s2pt, 0., 1., log_p);

#ifdef DEBUG_p
	REprintf ("pp*_asymp(): f=%.14g	 np=%.14g  nd=%.14g  f*nd=%.14g\n",
		  f, np, nd, f * nd);
#endif
	return np + f * nd;
    }
} /* ppois_asymp() */
Пример #24
0
Type nldens(Type x, Type mu, Type sd, Type p){
  Type z=(x-mu)/sd;
  return -log(1.0/sd*((1.0-p)*dnorm(z,Type(0.0),Type(1.0),false)+p*dt1(z)));
}
Пример #25
0
/**
   Setup the least square reconstruct by directly inverting GA matrix. 
   The reconstructor is simply the pseudo inverse of GA matrix:
   \f[\hat{x}=(G_a^TC_g^{-1}G_a)^{-1}G_a^TC_g^{-1}\f]

   This is very close to RR except replacing GX with GA.

   We use the tomograhy parameters for lsr, since lsr is simply "tomography" onto DM directly.
*/
void setup_recon_lsr(RECON_T *recon, const PARMS_T *parms){
    const int ndm=parms->ndm;
    const int nwfs=parms->nwfsr;
    cell *GAlsr;
    cell *GAM=parms->recon.modal?(cell*)recon->GM:(cell*)recon->GA;
    if(parms->recon.split){ //high order wfs only in split mode. 
	GAlsr=parms->recon.modal?(cell*)recon->GMhi:(cell*)recon->GAhi;
    }else{ //all wfs in integrated mode. 
	GAlsr=GAM;
    }
    int free_GAlsr=0;
    if(GAlsr->p[0]->id!=M_DBL){
	dsp *tmp=dsp_cast(GAlsr->p[0]);
	if(tmp->nzmax>tmp->nx*tmp->ny*0.2){//not very sparse
	    dcell *tmp2=0;
	    free_GAlsr=1;
	    dcelladd(&tmp2, 1, (dspcell*)GAlsr, 1);
	    GAlsr=(cell*)tmp2;
	}
    }
    info2("Building recon->LR\n");
    recon->LR.M=dcellmm2(GAlsr, recon->saneai, "tn");
    // Tip/tilt and diff focus removal low rand terms for LGS WFS.
    if(recon->TTF){
	dcellmm(&recon->LR.U, recon->LR.M, recon->TTF, "nn", 1);
	recon->LR.V=dcelltrans(recon->PTTF);
    }
    info2("Building recon->LL\n");
    recon->LL.M=dcellmm2(recon->LR.M, GAlsr, "nn");
    if(free_GAlsr){
	cellfree(GAlsr);
    }
    double maxeig=pow(recon->neamhi * recon->aloc->p[0]->dx, -2);
    if(parms->recon.modal){
	double strength=1;
	for(int idm=0; idm<ndm; idm++){
	    strength*=dnorm(recon->amod->p[idm]);
	}
	strength=pow(strength, 2./ndm);
	maxeig*=strength;
    }
    if(fabs(parms->lsr.tikcr)>EPS){
	info2("Adding tikhonov constraint of %g to LLM\n", parms->lsr.tikcr);
	info2("The maximum eigen value is estimated to be around %g\n", maxeig);
	dcelladdI(recon->LL.M, parms->lsr.tikcr*maxeig);
    }
    dcell *NW=NULL;
    if(!parms->recon.modal){
	if(parms->lsr.alg!=2){
	    /* Not SVD, need low rank terms for piston/waffle mode constraint. */
	    NW=dcellnew(ndm,1);
	    int nmod=2;/*two modes. */
	    for(int idm=0; idm<ndm; idm++){
		loc_create_map(recon->aloc->p[idm]);
		const long nloc=recon->aloc->p[idm]->nloc;
		NW->p[idm]=dnew(nloc, ndm*nmod);
		double *p=NW->p[idm]->p+nmod*idm*nloc;
		const double *cpl=recon->actcpl->p[idm]->p;
		for(long iloc=0; iloc<nloc; iloc++){
		    if(cpl[iloc]>0.1){
			p[iloc]=1;/*piston mode */
		    }
		}
		/*notice offset of 1 because map start count at 1 */
		p=NW->p[idm]->p+(1+nmod*idm)*nloc-1;
		map_t *map=recon->aloc->p[idm]->map;
		for(long iy=0; iy<map->ny; iy++){
		    for(long ix=0; ix<map->nx; ix++){
			if(IND(map,ix,iy)){
			    p[(long)IND(map,ix,iy)]=(double)2*((iy+ix)&1)-1;
			}
		    }
		}
	    }
	    /*scale it to match the magnitude of LL.M */
	    dcellscale(NW, sqrt(maxeig));
	    if(parms->save.setup){
		writebin(NW, "lsrNW");
	    }
	}
	if(parms->lsr.actslave){
	    /*actuator slaving. important. change from 0.5 to 0.1 on 2011-07-14. */
	    dspcell *actslave=slaving(recon->aloc, recon->actcpl, NW,
				      recon->actstuck, recon->actfloat, parms->lsr.actthres, maxeig);
	    if(parms->save.setup){
		if(NW){
		    writebin(NW, "lsrNW2");
		}
		writebin(actslave,"actslave");
	    }
	    dcelladd(&recon->LL.M, 1, actslave, 1);
	    cellfree(actslave);
	}
    }
    /*Low rank terms for low order wfs. Only in Integrated tomography. */
    dcell *ULo=dcellnew(ndm,nwfs);
    dcell *VLo=dcellnew(ndm,nwfs);
    dcell*  pULo=ULo/*PDELL*/;
    dcell*  pVLo=VLo/*PDELL*/;
    for(int iwfs=0; iwfs<nwfs; iwfs++){
	int ipowfs=parms->wfsr[iwfs].powfs;
	if(parms->powfs[ipowfs].skip || !parms->powfs[ipowfs].lo){
	    continue;
	}
	for(int idm=0; idm<ndm; idm++){
	    dspfull(PIND(pULo,idm,iwfs), (dsp*)IND(recon->LR.M, idm, iwfs),'n',-1);
	    dspfull(PIND(pVLo,idm,iwfs), (dsp*)IND(GAM, iwfs, idm),'t',1);
	}
    }
    recon->LL.U=dcellcat(recon->LR.U, ULo, 2);
    dcell *GPTTDF=NULL;
    dcellmm(&GPTTDF, GAM, recon->LR.V, "tn", 1);
    recon->LL.V=dcellcat(GPTTDF, VLo, 2);
    dcellfree(GPTTDF);
    dcellfree(ULo);
    dcellfree(VLo);
    if(!parms->recon.modal && NW){
	info2("Create piston and check board modes that are in NULL space of GA.\n");
	/*add to low rank terms. */
	dcell *tmp=recon->LL.U;
	recon->LL.U=dcellcat(tmp, NW, 2);
	dcellfree(tmp);
	dcellscale(NW, -1);
	tmp=recon->LL.V;
	recon->LL.V=dcellcat(tmp, NW, 2);
	dcellfree(tmp);
	dcellfree(NW);
    }
    if(parms->lsr.fnreg){
	warning("Loading LSR regularization from file %s.\n", parms->lsr.fnreg);
	dspcell *tmp=dspcellread("%s", parms->lsr.fnreg);
	dcelladd(&recon->LL.M, 1, tmp, 1);
	dspcellfree(tmp);
    }
    recon->LL.alg = parms->lsr.alg;
    recon->LL.bgs = parms->lsr.bgs;
    recon->LL.warm = parms->recon.warm_restart;
    recon->LL.maxit = parms->lsr.maxit;
    /*Remove empty cells. */
    dcelldropempty(&recon->LR.U,2);
    dcelldropempty(&recon->LR.V,2);
    dcelldropempty(&recon->LL.U,2);
    dcelldropempty(&recon->LL.V,2);
    if(parms->save.recon){
	writebin(recon->LR.M,"LRM");
	writebin(recon->LR.U,"LRU");
	writebin(recon->LR.V,"LRV");
	writebin(recon->LL.M,"LLM.bin");/*disable compression */
	writebin(recon->LL.U,"LLU");
	writebin(recon->LL.V,"LLV"); 
    }
    if(parms->lsr.alg==0 || parms->lsr.alg==2){
	if(!parms->lsr.bgs){
	    muv_direct_prep(&recon->LL, (parms->lsr.alg==2)*parms->lsr.svdthres);
	    if(parms->save.recon){
		if(recon->LL.C)
		    chol_save(recon->LL.C, "LLC.bin");
		else
		    writebin(recon->LL.MI, "LLMI.bin");
	    }
	    cellfree(recon->LL.M);
	    dcellfree(recon->LL.U);
	    dcellfree(recon->LL.V);	
	}else{
	    muv_direct_diag_prep(&(recon->LL), (parms->lsr.alg==2)*parms->lsr.svdthres);
	    if(parms->save.recon){
		for(int ib=0; ib<recon->LL.nb; ib++){
		    if(recon->LL.CB)
			chol_save(recon->LL.CB[ib],"LLCB_%d.bin", ib);
		    else
			writebin(recon->LL.MI,"LLMIB_%d.bin", ib);
		}
	    }
	    /*Don't free M, U, V */
	}
    }
}
Пример #26
0
static void init_pull_coord(t_pull_coord *pcrd,
                            char *dim_buf,
                            const char *origin_buf, const char *vec_buf,
                            warninp_t wi)
{
    int    m;
    dvec   origin, vec;
    char   buf[STRLEN];

    if (pcrd->eType == epullCONSTRAINT && (pcrd->eGeom == epullgCYL ||
                                           pcrd->eGeom == epullgDIRRELATIVE))
    {
        gmx_fatal(FARGS, "Pulling of type %s can not be combined with geometry %s. Consider using pull type %s.",
                  epull_names[pcrd->eType],
                  epullg_names[pcrd->eGeom],
                  epull_names[epullUMBRELLA]);
    }

    process_pull_dim(dim_buf, pcrd->dim);

    string2dvec(origin_buf, origin);
    if (pcrd->group[0] != 0 && dnorm(origin) > 0)
    {
        gmx_fatal(FARGS, "The pull origin can only be set with an absolute reference");
    }

    /* Check and set the pull vector */
    clear_dvec(vec);
    if (pcrd->eGeom == epullgDIST)
    {
        if (pcrd->init < 0)
        {
            sprintf(buf, "The initial pull distance is negative with geometry %s, while a distance can not be negative. Use geometry %s instead.",
                    EPULLGEOM(pcrd->eGeom), EPULLGEOM(epullgDIR));
            warning_error(wi, buf);
        }
        /* TODO: With a positive init but a negative rate things could still
         * go wrong, but it might be fine if you don't pull too far.
         * We should give a warning or note when there is only one pull dim
         * active, since that is usually the problematic case when you should
         * be using direction. We will do this later, since an already planned
         * generalization of the pull code makes pull dim available here.
         */
    }
    else if (pcrd->eGeom != epullgDIRRELATIVE)
    {
        string2dvec(vec_buf, vec);
        if (dnorm2(vec) == 0)
        {
            gmx_fatal(FARGS, "With pull geometry %s the pull vector can not be 0,0,0",
                      epullg_names[pcrd->eGeom]);
        }
        if (pcrd->eGeom == epullgDIR || pcrd->eGeom == epullgCYL)
        {
            /* Normalize the direction vector */
            dsvmul(1/dnorm(vec), vec, vec);
        }
    }
    for (m = 0; m < DIM; m++)
    {
        pcrd->origin[m] = origin[m];
        pcrd->vec[m]    = vec[m];
    }
}
Пример #27
0
void diffhfunc(double* u, double* v, int* n, double* param, int* copula, double* out)
{
    int j;
    double t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, t11, t12, t14, t15, t16, t18, t22, t24, t25, t27, t28, t32;

    double theta = param[0];
    //double delta = param[1];

    for(j=0;j<*n;j++)
    {
        if(*copula==0)
        {
            out[j]=0;
        }
        else if(*copula==1)
        {
            t1=qnorm(u[j],0.0,1.0,1,0);
            t2=qnorm(v[j],0.0,1.0,1,0);
            t3=t1-theta*t2;
            t4=1.0-pow(theta,2);
            t5=sqrt(t4);
            t6=t3/t5;
            t7=dnorm(t6,0.0,1.0,0);
            t8=-1.0*t2*t5+1.0*t3*theta/t5;
            t9=t8/t4;
            out[j]=t7*t9;
        }
        else if(*copula==3)
        {
            t1 = pow(v[j],-1.0*theta-1.0);
            t2 = log(v[j]);
            t3 = pow(u[j],-1.0*theta);
            t4 = pow(v[j],-1.0*theta);
            t5 = t3+t4-1.0;
            t6 = -1.0-1/theta;
            t7 = pow(t5,1.0*t6);
            t8 = theta*theta;
            t9 = log(t5);
            t10 = log(u[j]);
            out[j] = -t1*t2*t7+t1*t7*(1/t8*t9+t6*(-t3*t10-t4*t2)/t5);
        }
        else if(*copula==4)
        {
            t1 = log(v[j]);
            t2 = pow(-t1,1.0*theta);
            t3 = log(u[j]);
            t4 = pow(-t3,1.0*theta);
            t5 = t2+t4;
            t6 = 1/theta;
            t7 = pow(t5,1.0*t6);
            t8 = theta*theta;
            t9 = log(t5);
            t10 = 1/t8*t9;
            t11 = log(-t1);
            t14 = log(-t3);
            t16 = t2*t11+t4*t14;
            t18 = 1/t5;
            t22 = exp(-t7);
            t24 = t6-1.0;
            t25 = pow(t5,1.0*t24);
            t27 = 1/v[j];
            t28 = 1/t1;
            t32 = t22*t25;
            out[j] = t7*(-t10+t6*t16*t18)*t22*t25*t2*t27*t28-t32*(-t10+t24*t16*t18)*t2*t27*t28-t32*t2*t11*t27*t28;
        }
        else if(*copula==5)
        {
            t1 = exp(theta);
            t2 = theta*u[j];
            t3 = exp(t2);
            t5 = t1*(t3-1.0);
            t6 = theta*v[j];
            t8 = exp(t6+t2);
            t9 = exp(t6+theta);
            t10 = exp(t2+theta);
            t11 = t8-t9-t10+t1;
            t14 = 1/t11;
            t18 = t11*t11;
            out[j] = -t5*t14-t1*u[j]*t3*t14+t5/t18*((v[j]+u[j])*t8-(v[j]+1.0)*t9-(u[j]+1.0)*t10+t1);
        }
        else if(*copula==6)
        {
            t1 = 1.0-u[j];
            t2 = pow(t1,1.0*theta);
            t3 = 1.0-v[j];
            t4 = pow(t3,1.0*theta);
            t5 = t2*t4;
            t6 = t2+t4-t5;
            t8 = 1/theta-1.0;
            t9 = pow(t6,1.0*t8);
            t10 = theta*theta;
            t12 = log(t6);
            t14 = log(t1);
            t15 = t2*t14;
            t16 = log(t3);
            t27 = pow(t3,1.0*theta-1.0);
            t7 = 1.0-t2;
            t11 = t9*t27;
            out[j] = t9*(-1.0/t10*t12+t8*(t15+t4*t16-t15*t4-t5*t16)/t6)*t27*t7+t11*t16*t7-t11*t15;
        }
    }

}
Пример #28
0
/**
 * compute the log density of a truncated normal
 *
 * @param x the point at which the log density is computed
 * @param m the mean of the untruncated normal
 * @param sd the standard deviation of the untruncated normal
 * @param lb the left bound of the truncated normal
 * @param rb the right bound of the truncated normal
 *
 * @return the log density at the point x
 */
static R_INLINE double dtnorm(double x, double m, double sd, double lb, double rb){
  double c =  (R_FINITE(rb) ? pnorm(rb, m, sd, 1, 0) : 1.0) -
    (R_FINITE(lb) ? pnorm(lb, m, sd, 1, 0) : 0.0) ; 
  return dnorm(x, m, sd, 1) - log(c) ;
}
Пример #29
0
void model_parameters::calc_obj_fun(void)
{
  f=dnorm(epsilon,sig);
 
}
Пример #30
0
static double gammadens (double gamma_k, void *dens_data) {
  // Pointer to the structure: d 
  struct dens_par *d;
  d=dens_data;
  // Indicating the rank of the parameter of interest
  int k=d->pos_gamma; //
  // logLikelihood
  double logL=0.0;
  for (int i=0; i<d->NSITE; i++) {
    /* theta */
    double Xpart_theta=0.0;
    for (int p=0; p<d->NP; p++) {
      Xpart_theta+=d->X[i][p]*d->beta_run[p];
    }
    double theta=invlogit(Xpart_theta);
    /* delta */
    double logLpart=0.0;
    // At least one presence
    if (d->SumYbySite[i]>0) {
      for (int m=0; m<d->nObsSite[i]; m++) {
        int w=d->PosSite[i][m]; // which observation
        double logit_delta=0.0;
        for (int q=0; q<d->NQ; q++) {
          if (q!=k) {
            logit_delta+=d->W[w][q]*d->gamma_run[q];
          }
        }
        logit_delta+=d->W[w][k]*gamma_k;
        double delta=invlogit(logit_delta);
        /* logLpart */
        if (d->Y[w]==1) {
          logLpart+=log(delta);
        }
        if (d->Y[w]==0) {
          logLpart+=log(1-delta);
        }
      }
      logL+=logLpart+log(theta);
    }
    // Only absences
    if (d->SumYbySite[i]==0) {
      for (int m=0; m<d->nObsSite[i]; m++) {
        int w=d->PosSite[i][m]; // which observation
        double logit_delta=0.0;
        for (int q=0; q<d->NQ; q++) {
          if (q!=k) {
            logit_delta+=d->W[w][q]*d->gamma_run[q];
          }
        }
        logit_delta+=d->W[w][k]*gamma_k;
        double delta=invlogit(logit_delta);
        /* logLpart */
        logLpart+=log(1-delta);
      }
      logL+=log(exp(logLpart)*theta+(1-theta));
    }
  }
  // logPosterior=logL+logPrior
  double logP=logL+dnorm(gamma_k,d->mugamma[k],sqrt(d->Vgamma[k]),1); 
  return logP;
}