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; }
/* # 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; }
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; } } }
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); }
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), ¶ms[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(¶ms[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); }
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; }
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)); }
/* 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); }
/* 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); }
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; } }
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; }
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; }
/***** ***************************************************************************************** *****/ 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; }
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(); }
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]; } }
/* 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); }
/* 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); }
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 */ }
/* * 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() */
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))); }
/** 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 */ } } }
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]; } }
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; } } }
/** * 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) ; }
void model_parameters::calc_obj_fun(void) { f=dnorm(epsilon,sig); }
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; }