void advance_in_time ( double time_step, double position[3], double new_position[3] )
{
/* Move a point along the Lorenz attractor */
double deriv0[3], deriv1[3], deriv2[3], deriv3[3] ;
int i ;
memcpy ( new_position, position, 3 * sizeof(double) ) ; /* Save the present values */
/* First pass in a Fourth-Order Runge-Kutta integration method */
calc_deriv ( position, deriv0 ) ;
for ( i = 0; i < 3; i++ )
new_position[i] = position[i] + 0.5 * time_step * deriv0[i] ;
/* Second pass */
calc_deriv ( new_position, deriv1 ) ;
for ( i = 0; i < 3; i++ )
new_position[i] = position[i] + 0.5 * time_step * deriv1[i] ;
/* Third pass */
calc_deriv ( position, deriv2 ) ;
for ( i = 0; i < 3; i++ )
new_position[i] = position[i] + time_step * deriv2[i] ;
/* Second pass */
calc_deriv ( new_position, deriv3 ) ;
for ( i = 0; i < 3; i++ )
new_position[i] = position[i] + 0.1666666666666666667 * time_step *
( deriv0[i] + 2.0 * ( deriv1[i] + deriv2[i] ) + deriv3[i] ) ;
}
void add_visc(Field *fld) {
visc_tens(fld);
/* Calculate div(Pi) */
calc_deriv(fld->Tens->Pixx,fld->Tens->divPix,NULL,fld->Params->dx,fld->kk);
calc_deriv(fld->Tens->Pixy,fld->Tens->divPiy,fld->Tens->divPix,fld->Params->dx,fld->kk);
calc_deriv(fld->Tens->Piyy,NULL,fld->Tens->divPiy,fld->Params->dx,fld->kk);
/* Convolve with 1/Sigma */
convolve_inv(&fld->sig[istart],&fld->Tens->divPix[istart],fld->dtu,1);
convolve_inv(&fld->sig[istart],&fld->Tens->divPiy[istart],fld->dtv,1);
return;
}
/**
* Calculates the log likelihood (log probability of model given the
* data) and gradient. If the calc_ll flag is FALSE, the
* log-likelihood is not calculated and 0.0 is returned. If the
* calc_grad flag is FALSE the gradient is not calculated and the
* model partial derivatives are not updated.
*/
double bkgd_evo_mdl_calc_ll(Model *mdl, int calc_ll, int calc_grad) {
BkgdEvoMdlParam param, ll_deriv;
Branch *br;
ColType *cltype;
BkgdEvoMdlConfig *conf;
BkgdEvoMdlData *data;
double ll;
ColTypeStat *clstat, *cons_clstat;
long i;
int j;
conf = mdl->config;
data = mdl->data;
if(data == NULL) {
g_error("bkgd_evo_mdl_calc_ll: data must be set before "
"likelihood can be calculated\n");
}
param_set_zero(¶m);
param_set_zero(&ll_deriv);
set_bkgd_evo_param_from_model(mdl, conf, ¶m);
ll = 0.0;
clstat = g_new(ColTypeStat, conf->n_cltype);
cons_clstat = NULL;
for(i = 0; i < conf->n_cltype; i++) {
clstat[i].n = 0;
clstat[i].ttl_prob = 0.0;
clstat[i].ttl_prob_double = 0.0;
clstat[i].ttl_prob_single = 0.0;
clstat[i].ttl_ll = 0.0;
}
for(i = 0; i < data->n_bin; i++) {
/* Combine non-exonic and exonic B vals and rescale by new
* deleterious rate estimates. Use precomputed log B values so
* that rescaling is more efficient (do not need to take logs
* first and then re-exponentiate)
*/
param.B = exp(data->bin[i].lB_ex * param.u_ex_scale +
data->bin[i].lB_nex * param.u_nex_scale);
if(param.B < 0.0 || param.B > 1.0 || isnan(param.B) || isinf(param.B)) {
g_error("bkgd_evo_mdl_calc_ll: invalid B (%g)\n"
"B_ex=%g, B_nex=%g, u_ex_scale=%g, u_nex_scale=%g\n",
param.B, data->bin[i].B_ex, data->bin[i].B_nex,
param.u_ex_scale, param.u_nex_scale);
}
/* calculate mutation rate for current bin */
bkgd_evo_mdl_calc_mu(¶m, mdl, &data->bin[i]);
/* calculate probability HC coalescent predates HC/G speciation */
if(param.T_hcg == 0.0) {
param.k_hcg = 1.0;
} else {
param.k_hcg = exp(-0.5 * param.T_hcg / (param.B * param.N_hc));
if(param.k_hcg > 1.0 || param.k_hcg < 0.0) {
g_error("bkgd_evo_mdl_calc_ll: invalid probability of HC "
"coalescent predating gorilla speciation: k_hcg=%g\n",
param.k_hcg);
}
}
/* calculate branch lengths and substitution probs for current bin */
for(j = 0; j < conf->n_branch; j++) {
br = &conf->branches[j];
br->set_len(br, ¶m);
if(br->len < 0.0 || isnan(br->len) || isinf(br->len)) {
g_warning("bkgd_evo_mdl_calc_ll: invalid length (%g) for branch %s",
br->len, br->name);
br->len = BRANCH_LEN_SMALL;
}
branch_set_prob(br, ¶m, conf);
}
/* calc prob of observing each observed column type for bin */
for(j = 0; j < conf->n_cltype; j++) {
cltype = conf->cltypes[j];
/* do only non-conserved columns first */
if(cltype->subst_type == SUBST_TYPE_CONSERVED) {
cons_clstat = &clstat[j];
continue;
}
cltype->set_n(cltype, &data->bin[i]);
/* compute prob of a single observed column */
cltype_set_prob(cltype, ¶m, conf);
if(cltype->n > 0) {
/* add contribution to log-likelihood */
if(cltype->prob > 1.0 || cltype->prob < 0.0) {
g_error("bkgd_evo_mdl_calc_ll: invalid probability (%g) "
"for column type '%s'", cltype->prob, cltype->name);
}
if(cltype->prob < 1e-20) {
fprintf(stderr, "LOW prob column %s: p=%g\n", cltype->name,
cltype->prob);
}
ll += (double)cltype->n * log(cltype->prob);
/* for debugging and analysis purposes record some statistics
* about each column type
*/
clstat[j].n += cltype->n;
clstat[j].ttl_prob += cltype->prob;
clstat[j].ttl_prob_double += cltype->prob_ttl_double;
clstat[j].ttl_prob_single += cltype->prob_single;
clstat[j].ttl_ll += (double)cltype->n * log(cltype->prob);
}
}
/* now add the contribution from the conserved column */
if(conf->cons_cltype != NULL) {
cltype = conf->cons_cltype;
cltype->set_n(cltype, &data->bin[i]);
/* compute prob of a single observed column */
cltype_cons_set_prob(cltype, ¶m, conf);
if(cltype->n > 0) {
/* add contribution to log-likelihood */
if(cltype->prob > 1.0 || cltype->prob < 0.0) {
g_error("bkgd_evo_mdl_calc_ll: invalid probability (%g) "
"for column type '%s'", cltype->prob, cltype->name);
}
if(cltype->prob < 1e-20) {
fprintf(stderr, "LOW prob column %s: p=%g\n", cltype->name,
cltype->prob);
}
ll += (double)cltype->n * log(cltype->prob);
/* fprintf(stderr, "bin=%ld, CONS prob=%g\n", i, cltype->prob);*/
cons_clstat->n += cltype->n;
cons_clstat->ttl_prob += cltype->prob;
cons_clstat->ttl_prob_double += cltype->prob_ttl_double;
cons_clstat->ttl_prob_single += cltype->prob_single;
cons_clstat->ttl_ll += (double)cltype->n * log(cltype->prob);
}
}
if(calc_grad) {
/* perform derivative calculations **/
calc_deriv( &ll_deriv, conf, ¶m, &data->bin[i]);
}
}
if(calc_grad) {
/* update model's derivatives */
bkgd_evo_mdl_set_mdl_deriv(mdl, &ll_deriv);
/* model_write_grad_ln(mdl, stderr);*/
}
/* for(i = 0; i < conf->n_cltype; i++) { */
/* double dbl_pp, single_pp, avg_p; */
/* char *name; */
/* name = conf->cltypes[i]->name; */
/* avg_p = clstat[i].ttl_prob / (double)clstat[i].n; */
/* single_pp = clstat[i].ttl_prob_single / clstat[i].ttl_prob; */
/* dbl_pp = clstat[i].ttl_prob_double / clstat[i].ttl_prob; */
/* fprintf(stderr, " %s: n=%ld, LL=%g, p(%s)=%g, " */
/* "p(single|%s)=%g, p(double|%s)=%g\n", */
/* name, clstat[i].n, clstat[i].ttl_ll, name, avg_p, */
/* name, single_pp, name, dbl_pp); */
/* } */
g_free(clstat);
return ll;
}
