//Wishart distribution random number generator
int ran_wishart(const gsl_rng *r, const double nu,
const gsl_matrix *V, gsl_matrix *X)
{
const int k = V->size1;
int i, j;
gsl_matrix *A = gsl_matrix_calloc(k, k);
gsl_matrix *L = gsl_matrix_alloc(k, k);
for(i=0; i<k; i++)
{
gsl_matrix_set(A, i, i, sqrt(gsl_ran_chisq(r, (nu-i))));
for (j=0; j<i; j++){
gsl_matrix_set(A, i, j, gsl_ran_gaussian(r, 1));
}
}
gsl_matrix_memcpy(L, V);
gsl_linalg_cholesky_decomp(L);
gsl_blas_dtrmm(CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, 1.0, L, A);
gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, A, A, 0.0, X);
gsl_matrix_free(A);
gsl_matrix_free(L);
return 0;
}
double
gsl_ran_tdist (const gsl_rng * r, const double nu)
{
if (nu <= 2)
{
double Y1 = gsl_ran_ugaussian (r);
double Y2 = gsl_ran_chisq (r, nu);
double t = Y1 / sqrt (Y2 / nu);
return t;
}
else
{
double Y1, Y2, Z, t;
do
{
Y1 = gsl_ran_ugaussian (r);
Y2 = gsl_ran_exponential (r, 1 / (nu/2 - 1));
Z = Y1 * Y1 / (nu - 2);
}
while (1 - Z < 0 || exp (-Y2 - Z) > (1 - Z));
/* Note that there is a typo in Knuth's formula, the line below
is taken from the original paper of Marsaglia, Mathematics of
Computation, 34 (1980), p 234-256 */
t = Y1 / sqrt ((1 - 2 / nu) * (1 - Z));
return t;
}
}
void pplfunc_frandomcs (ppl_context *c, pplObj *in, int nArgs, int *status, int *errType, char *errText)
{
char *FunctionDescription = "chisq(nu)";
if (rndgen==NULL) { rndgen = gsl_rng_alloc(gsl_rng_default); gsl_rng_set(rndgen, 0); }
OUTPUT.real = gsl_ran_chisq(rndgen, in[0].real);
CHECK_OUTPUT_OKAY;
}
void librdist_chisq(gsl_rng *rng, int argc, void *argv, int bufc, float *buf){
t_atom *av = (t_atom *)argv;
if(argc != librdist_getnargs(ps_chisq)){
return;
}
const double nu = librdist_atom_getfloat(av);
int i;
for(i = 0; i < bufc; i++)
buf[i] = (float)gsl_ran_chisq(rng, nu);
}
extern double dist_chisq (struct _flow *flow, const double nu)
{
#ifdef HAVE_LIBGSL
gsl_rng * r = flow->r;
return gsl_ran_chisq(r, nu);
#else
/* not implemented */
UNUSED_ARGUMENT(flow);
UNUSED_ARGUMENT(nu);
return 0;
#endif /* HAVE_LIBGSL */
}
int rwishart(const gsl_rng *r, const unsigned int n, const unsigned int dof, const gsl_matrix *scale, gsl_matrix *result)
{
unsigned int k,l;
gsl_matrix *work = gsl_matrix_calloc(n,n);
for(k=0; k<n; k++){
gsl_matrix_set( work, k, k, sqrt( gsl_ran_chisq( r, (dof-k) ) ) );
for(l=0; l<k; l++)
gsl_matrix_set( work, k, l, gsl_ran_ugaussian(r) );
}
gsl_matrix_memcpy(result,scale);
gsl_linalg_cholesky_decomp(result);
gsl_blas_dtrmm(CblasLeft,CblasLower,CblasNoTrans,CblasNonUnit,1.0,result,work);
gsl_blas_dsyrk(CblasUpper,CblasNoTrans,1.0,work,0.0,result);
return 0;
}
int ran_mv_t(const gsl_rng *r, const gsl_vector *mu,
const gsl_matrix *Sigma, const double nu, gsl_vector *x)
{
const int k = mu->size;
gsl_matrix *A = gsl_matrix_alloc(k, k);
double v;
v = gsl_ran_chisq(r, nu);
gsl_matrix_memcpy(A, Sigma);
gsl_linalg_cholesky_decomp(A);
ran_mv_normal(r, mu, Sigma, x);
gsl_blas_dtrmv(CblasLower, CblasNoTrans, CblasNonUnit, A, x);
gsl_vector_scale(x, 1/sqrt(v));
gsl_vector_add(x, mu);
gsl_matrix_free(A);
return 0;
}
int
main (int argc, char *argv[])
{
size_t i,j;
size_t n = 0;
double mu = 0, nu = 0, nu1 = 0, nu2 = 0, sigma = 0, a = 0, b = 0, c = 0;
double zeta = 0, sigmax = 0, sigmay = 0, rho = 0;
double p = 0;
double x = 0, y =0, z=0 ;
unsigned int N = 0, t = 0, n1 = 0, n2 = 0 ;
unsigned long int seed = 0 ;
const char * name ;
gsl_rng * r ;
if (argc < 4)
{
printf (
"Usage: gsl-randist seed n DIST param1 param2 ...\n"
"Generates n samples from the distribution DIST with parameters param1,\n"
"param2, etc. Valid distributions are,\n"
"\n"
" beta\n"
" binomial\n"
" bivariate-gaussian\n"
" cauchy\n"
" chisq\n"
" dir-2d\n"
" dir-3d\n"
" dir-nd\n"
" erlang\n"
" exponential\n"
" exppow\n"
" fdist\n"
" flat\n"
" gamma\n"
" gaussian-tail\n"
" gaussian\n"
" geometric\n"
" gumbel1\n"
" gumbel2\n"
" hypergeometric\n"
" laplace\n"
" landau\n"
" levy\n"
" levy-skew\n"
" logarithmic\n"
" logistic\n"
" lognormal\n"
" negative-binomial\n"
" pareto\n"
" pascal\n"
" poisson\n"
" rayleigh-tail\n"
" rayleigh\n"
" tdist\n"
" ugaussian-tail\n"
" ugaussian\n"
" weibull\n") ;
exit (0);
}
argv++ ; seed = atol (argv[0]); argc-- ;
argv++ ; n = atol (argv[0]); argc-- ;
argv++ ; name = argv[0] ; argc-- ; argc-- ;
gsl_rng_env_setup() ;
if (gsl_rng_default_seed != 0) {
fprintf(stderr,
"overriding GSL_RNG_SEED with command line value, seed = %ld\n",
seed) ;
}
gsl_rng_default_seed = seed ;
r = gsl_rng_alloc(gsl_rng_default) ;
#define NAME(x) !strcmp(name,(x))
#define OUTPUT(x) for (i = 0; i < n; i++) { printf("%g\n", (x)) ; }
#define OUTPUT1(a,x) for(i = 0; i < n; i++) { a ; printf("%g\n", x) ; }
#define OUTPUT2(a,x,y) for(i = 0; i < n; i++) { a ; printf("%g %g\n", x, y) ; }
#define OUTPUT3(a,x,y,z) for(i = 0; i < n; i++) { a ; printf("%g %g %g\n", x, y, z) ; }
#define INT_OUTPUT(x) for (i = 0; i < n; i++) { printf("%d\n", (x)) ; }
#define ARGS(x,y) if (argc != x) error(y) ;
#define DBL_ARG(x) if (argc) { x=atof((++argv)[0]);argc--;} else {error( #x);};
#define INT_ARG(x) if (argc) { x=atoi((++argv)[0]);argc--;} else {error( #x);};
if (NAME("bernoulli"))
{
ARGS(1, "p = probability of success");
DBL_ARG(p)
INT_OUTPUT(gsl_ran_bernoulli (r, p));
}
else if (NAME("beta"))
{
ARGS(2, "a,b = shape parameters");
DBL_ARG(a)
DBL_ARG(b)
OUTPUT(gsl_ran_beta (r, a, b));
}
else if (NAME("binomial"))
{
ARGS(2, "p = probability, N = number of trials");
DBL_ARG(p)
INT_ARG(N)
INT_OUTPUT(gsl_ran_binomial (r, p, N));
}
else if (NAME("cauchy"))
{
ARGS(1, "a = scale parameter");
DBL_ARG(a)
OUTPUT(gsl_ran_cauchy (r, a));
}
else if (NAME("chisq"))
{
ARGS(1, "nu = degrees of freedom");
DBL_ARG(nu)
OUTPUT(gsl_ran_chisq (r, nu));
}
else if (NAME("erlang"))
{
ARGS(2, "a = scale parameter, b = order");
DBL_ARG(a)
DBL_ARG(b)
OUTPUT(gsl_ran_erlang (r, a, b));
}
else if (NAME("exponential"))
{
ARGS(1, "mu = mean value");
DBL_ARG(mu) ;
OUTPUT(gsl_ran_exponential (r, mu));
}
else if (NAME("exppow"))
{
ARGS(2, "a = scale parameter, b = power (1=exponential, 2=gaussian)");
DBL_ARG(a) ;
DBL_ARG(b) ;
OUTPUT(gsl_ran_exppow (r, a, b));
}
else if (NAME("fdist"))
{
ARGS(2, "nu1, nu2 = degrees of freedom parameters");
DBL_ARG(nu1) ;
DBL_ARG(nu2) ;
OUTPUT(gsl_ran_fdist (r, nu1, nu2));
}
else if (NAME("flat"))
{
ARGS(2, "a = lower limit, b = upper limit");
DBL_ARG(a) ;
DBL_ARG(b) ;
OUTPUT(gsl_ran_flat (r, a, b));
}
else if (NAME("gamma"))
{
ARGS(2, "a = order, b = scale");
DBL_ARG(a) ;
DBL_ARG(b) ;
OUTPUT(gsl_ran_gamma (r, a, b));
}
else if (NAME("gaussian"))
{
ARGS(1, "sigma = standard deviation");
DBL_ARG(sigma) ;
OUTPUT(gsl_ran_gaussian (r, sigma));
}
else if (NAME("gaussian-tail"))
{
ARGS(2, "a = lower limit, sigma = standard deviation");
DBL_ARG(a) ;
DBL_ARG(sigma) ;
OUTPUT(gsl_ran_gaussian_tail (r, a, sigma));
}
else if (NAME("ugaussian"))
{
ARGS(0, "unit gaussian, no parameters required");
OUTPUT(gsl_ran_ugaussian (r));
}
else if (NAME("ugaussian-tail"))
{
ARGS(1, "a = lower limit");
DBL_ARG(a) ;
OUTPUT(gsl_ran_ugaussian_tail (r, a));
}
else if (NAME("bivariate-gaussian"))
{
ARGS(3, "sigmax = x std.dev., sigmay = y std.dev., rho = correlation");
DBL_ARG(sigmax) ;
DBL_ARG(sigmay) ;
DBL_ARG(rho) ;
OUTPUT2(gsl_ran_bivariate_gaussian (r, sigmax, sigmay, rho, &x, &y),
x, y);
}
else if (NAME("dir-2d"))
{
OUTPUT2(gsl_ran_dir_2d (r, &x, &y), x, y);
}
else if (NAME("dir-3d"))
{
OUTPUT3(gsl_ran_dir_3d (r, &x, &y, &z), x, y, z);
}
else if (NAME("dir-nd"))
{
double *xarr;
ARGS(1, "n1 = number of dimensions of hypersphere");
INT_ARG(n1) ;
xarr = (double *)malloc(n1*sizeof(double));
for(i = 0; i < n; i++) {
gsl_ran_dir_nd (r, n1, xarr) ;
for (j = 0; j < n1; j++) {
if (j) putchar(' ');
printf("%g", xarr[j]) ;
}
putchar('\n');
} ;
free(xarr);
}
else if (NAME("geometric"))
{
ARGS(1, "p = bernoulli trial probability of success");
DBL_ARG(p) ;
INT_OUTPUT(gsl_ran_geometric (r, p));
}
else if (NAME("gumbel1"))
{
ARGS(2, "a = order, b = scale parameter");
DBL_ARG(a) ;
DBL_ARG(b) ;
OUTPUT(gsl_ran_gumbel1 (r, a, b));
}
else if (NAME("gumbel2"))
{
ARGS(2, "a = order, b = scale parameter");
DBL_ARG(a) ;
DBL_ARG(b) ;
OUTPUT(gsl_ran_gumbel2 (r, a, b));
}
else if (NAME("hypergeometric"))
{
ARGS(3, "n1 = tagged population, n2 = untagged population, t = number of trials");
INT_ARG(n1) ;
INT_ARG(n2) ;
INT_ARG(t) ;
INT_OUTPUT(gsl_ran_hypergeometric (r, n1, n2, t));
}
else if (NAME("laplace"))
{
ARGS(1, "a = scale parameter");
DBL_ARG(a) ;
OUTPUT(gsl_ran_laplace (r, a));
}
else if (NAME("landau"))
{
ARGS(0, "no arguments required");
OUTPUT(gsl_ran_landau (r));
}
else if (NAME("levy"))
{
ARGS(2, "c = scale, a = power (1=cauchy, 2=gaussian)");
DBL_ARG(c) ;
DBL_ARG(a) ;
OUTPUT(gsl_ran_levy (r, c, a));
}
else if (NAME("levy-skew"))
{
ARGS(3, "c = scale, a = power (1=cauchy, 2=gaussian), b = skew");
DBL_ARG(c) ;
DBL_ARG(a) ;
DBL_ARG(b) ;
OUTPUT(gsl_ran_levy_skew (r, c, a, b));
}
else if (NAME("logarithmic"))
{
ARGS(1, "p = probability");
DBL_ARG(p) ;
INT_OUTPUT(gsl_ran_logarithmic (r, p));
}
else if (NAME("logistic"))
{
ARGS(1, "a = scale parameter");
DBL_ARG(a) ;
OUTPUT(gsl_ran_logistic (r, a));
}
else if (NAME("lognormal"))
{
ARGS(2, "zeta = location parameter, sigma = scale parameter");
DBL_ARG(zeta) ;
DBL_ARG(sigma) ;
OUTPUT(gsl_ran_lognormal (r, zeta, sigma));
}
else if (NAME("negative-binomial"))
{
ARGS(2, "p = probability, a = order");
DBL_ARG(p) ;
DBL_ARG(a) ;
INT_OUTPUT(gsl_ran_negative_binomial (r, p, a));
}
else if (NAME("pareto"))
{
ARGS(2, "a = power, b = scale parameter");
DBL_ARG(a) ;
DBL_ARG(b) ;
OUTPUT(gsl_ran_pareto (r, a, b));
}
else if (NAME("pascal"))
{
ARGS(2, "p = probability, n = order (integer)");
DBL_ARG(p) ;
INT_ARG(N) ;
INT_OUTPUT(gsl_ran_pascal (r, p, N));
}
else if (NAME("poisson"))
{
ARGS(1, "mu = scale parameter");
DBL_ARG(mu) ;
INT_OUTPUT(gsl_ran_poisson (r, mu));
}
else if (NAME("rayleigh"))
{
ARGS(1, "sigma = scale parameter");
DBL_ARG(sigma) ;
OUTPUT(gsl_ran_rayleigh (r, sigma));
}
else if (NAME("rayleigh-tail"))
{
ARGS(2, "a = lower limit, sigma = scale parameter");
DBL_ARG(a) ;
DBL_ARG(sigma) ;
OUTPUT(gsl_ran_rayleigh_tail (r, a, sigma));
}
else if (NAME("tdist"))
{
ARGS(1, "nu = degrees of freedom");
DBL_ARG(nu) ;
OUTPUT(gsl_ran_tdist (r, nu));
}
else if (NAME("weibull"))
{
ARGS(2, "a = scale parameter, b = exponent");
DBL_ARG(a) ;
DBL_ARG(b) ;
OUTPUT(gsl_ran_weibull (r, a, b));
}
else
{
fprintf(stderr,"Error: unrecognized distribution: %s\n", name) ;
}
return 0 ;
}
void gen_rand_state_synth(double *const x, unsigned int N, gsl_rng *r, TMCMCParams ¶ms) {
assert(N == 1 + params.N_DM + 4*params.N_stars);
// R_V
x[0] = 3.1 + gsl_ran_gaussian_ziggurat(r, 0.2);
// Delta_EBV
for(size_t i=0; i<params.N_DM; i++) { x[i+1] = params.data->EBV / (double)params.N_DM * gsl_ran_chisq(r, 1.); }
// Stars
TSED sed_tmp(true);
for(size_t i = 1 + params.N_DM; i < 1 + params.N_DM + 4*params.N_stars; i += 4) {
// DM
x[i] = 5. + 13. * gsl_rng_uniform(r);
// Stellar type
double logMass, logtau, FeH, tau;
bool in_lib = false;
while(!in_lib) {
logMass = gsl_ran_gaussian_ziggurat(r, 0.5);
tau = -1.;
while(tau <= 0.) {
tau = 1.e9 * (5. + gsl_ran_gaussian_ziggurat(r, 2.));
}
logtau = log10(tau);
FeH = -1.0 + gsl_ran_gaussian_ziggurat(r, 1.);
in_lib = params.synth_stellar_model->get_sed(logMass, logtau, FeH, sed_tmp);
}
x[i+1] = logMass;
x[i+2] = logtau;
x[i+3] = FeH;
}
}
void sample_model_synth(TGalacticLOSModel &galactic_model, TSyntheticStellarModel &stellar_model, TExtinctionModel &extinction_model, TStellarData &stellar_data) {
unsigned int N_DM = 20;
double DM_min = 5.;
double DM_max = 20.;
TMCMCParams params(&galactic_model, &stellar_model, NULL, &extinction_model, &stellar_data, N_DM, DM_min, DM_max);
TMCMCParams params_tmp(&galactic_model, &stellar_model, NULL, &extinction_model, &stellar_data, N_DM, DM_min, DM_max);
// Random number generator
gsl_rng *r;
seed_gsl_rng(&r);
// Vector describing position in probability space
size_t length = 1 + params.N_DM + 4*params.N_stars;
// x = {RV, Delta_EBV_1, ..., Delta_EBV_M, Theta_1, ..., Theta_N}, where Theta = {DM, logMass, logtau, FeH}.
double *x = new double[length];
// Random starting point for reddening profile
x[0] = 3.1;// + gsl_ran_gaussian_ziggurat(r, 0.2); // RV
for(size_t i=0; i<params.N_DM; i++) { x[i+1] = params.data->EBV / (double)N_DM * gsl_ran_chisq(r, 1.); } // Delta_EBV
// Random starting point for each star
TSED sed_tmp(true);
for(size_t i = 1 + params.N_DM; i < 1 + params.N_DM + 4*params.N_stars; i += 4) {
x[i] = 5. + 13.*gsl_rng_uniform(r);
double logMass, logtau, FeH, tau;
bool in_lib = false;
while(!in_lib) {
logMass = gsl_ran_gaussian_ziggurat(r, 0.5);
tau = -1.;
while(tau <= 0.) {
tau = 1.e9 * (5. + gsl_ran_gaussian_ziggurat(r, 2.));
}
logtau = log10(tau);
FeH = -1.0 + gsl_ran_gaussian_ziggurat(r, 1.);
in_lib = stellar_model.get_sed(logMass, logtau, FeH, sed_tmp);
}
x[i+1] = logMass;
x[i+2] = logtau;
x[i+3] = FeH;
}
params.update_EBV_interp(x);
double *lnp_star = new double[params.N_stars];
double lnp_los = logP_los_synth(x, length, params, lnp_star);
std::cerr << "# ln p(x_0) = " << lnp_los << std::endl;
double *x_tmp = new double[length];
double Theta_tmp[4];
double sigma_Theta[4] = {0.1, 0.1, 0.1, 0.1};
double sigma_RV = 0.05;
double sigma_lnEBV = 0.1;
double lnp_tmp;
double *lnp_star_tmp = new double[params.N_stars];
double p;
unsigned int N_steps = 1000000;
TChain chain(length, N_steps);
TStats EBV_stats(N_DM);
// In each step
unsigned int N_star = 0;
unsigned int N_accept_star = 0;
unsigned int N_los = 0;
unsigned int N_accept_los = 0;
bool accept;
bool burn_in = true;
for(unsigned int i=0; i<N_steps; i++) {
if(i == N_steps/2) {
sigma_Theta[0] = 0.05;
sigma_Theta[1] = 0.05;
sigma_Theta[2] = 0.05;
sigma_Theta[3] = 0.05;
sigma_RV = 0.005;
sigma_lnEBV = 0.05;
burn_in = false;
}
// Step each star
for(unsigned int n=0; n<params.N_stars; n++) {
if(!burn_in) { N_star++; }
rand_gaussian_vector(&Theta_tmp[0], &x[1+N_DM+4*n], &sigma_Theta[0], 4, r);
lnp_tmp = logP_single_star_synth(&Theta_tmp[0], params.get_EBV(Theta_tmp[_DM]), x[0], galactic_model, stellar_model, extinction_model, stellar_data.star[n]);
accept = false;
if(lnp_tmp > lnp_star[n]) {
accept = true;
} else {
p = gsl_rng_uniform(r);
if((p > 0.) && (log(p) < lnp_tmp - lnp_star[n])) {
accept = true;
}
}
if(accept) {
if(!burn_in) { N_accept_star++; }
for(size_t k=0; k<4; k++) { x[1+N_DM+4*n+k] = Theta_tmp[k]; }
lnp_los += lnp_tmp - lnp_star[n];
lnp_star[n] = lnp_tmp;
}
}
// Step reddening profile
if(!burn_in) { N_los++; }
for(size_t k=0; k<length; k++) { x_tmp[k] = x[k]; }
//if(!burn_in) { x_tmp[0] += gsl_ran_gaussian_ziggurat(r, sigma_RV); }
for(unsigned int m=0; m<params.N_DM; m++) { x_tmp[1+m] += gsl_ran_gaussian_ziggurat(r, sigma_lnEBV); }
params_tmp.update_EBV_interp(x_tmp);
lnp_tmp = logP_los_synth(x_tmp, length, params_tmp, lnp_star_tmp);
//if(isinf(lnp_tmp)) {
// lnp_tmp = logP_los(x, length, params_tmp, lnp_star_tmp);
//}
//std::cerr << "# ln p(y) = " << lnp_tmp << std::endl;
accept = false;
if(lnp_tmp > lnp_los) {
accept = true;
} else if(log(gsl_rng_uniform(r)) < lnp_tmp - lnp_los) {
accept = true;
}
if(accept) {
if(!burn_in) { N_accept_los++; }
for(size_t k=0; k<1+N_DM; k++) { x[k] = x_tmp[k]; }
for(size_t k=0; k<params.N_stars; k++) { lnp_star[k] = lnp_star_tmp[k]; }
lnp_los = lnp_tmp;
params.update_EBV_interp(x);
//std::cerr << "# ln p(x) = " << lnp_los << std::endl;
}
if(!burn_in) {
chain.add_point(x, lnp_los, 1.);
x_tmp[0] = exp(x[1]);
for(size_t k=1; k<N_DM; k++) {
x_tmp[k] = x_tmp[k-1] + exp(x[k]);
}
EBV_stats(x_tmp, 1);
}
}
std::cerr << "# ln p(x) = " << lnp_los << std::endl;
std::cout.precision(4);
std::cerr << std::endl;
std::cerr << "# % acceptance: " << 100. * (double)N_accept_star / (double)N_star << " (stars)" << std::endl;
std::cerr << " " << 100. * (double)N_accept_los / (double)N_los << " (extinction)" << std::endl;
std::cerr << "# R_V = " << x[0] << std::endl << std::endl;
std::cerr << "# DM E(B-V)" << std::endl;
std::cerr << "# =============" << std::endl;
for(double DM=5.; DM<20.; DM+=1.) {
std::cerr << "# " << DM << " " << params.get_EBV(DM) << std::endl;
}
std::cerr << std::endl;
EBV_stats.print();
std::cerr << std::endl;
delete[] x;
delete[] x_tmp;
delete[] lnp_star;
delete[] lnp_star_tmp;
}
double
test_chisq (void)
{
return gsl_ran_chisq (r_global, 13.0);
}
static long double wishart_ll(apop_data *in, apop_model *m){
Nullcheck_mpd(in, m, GSL_NAN);
wishartstruct_t ws = {
.paraminv = apop_matrix_inverse(m->parameters->matrix),
.len = sqrt(in->matrix->size2),
.df = m->parameters->vector->data[0]
};
double paramdet = apop_matrix_determinant(m->parameters->matrix);
if (paramdet < 1e-3) return GSL_NEGINF;
double ll = apop_map_sum(in, .fn_vp = one_wishart_row, .param=&ws, .part='r');
double k = log(ws.df)*ws.df/2.;
k -= M_LN2 * ws.len* ws.df/2.;
k -= log(paramdet) * ws.df/2.;
k -= apop_multivariate_lngamma(ws.df/2., ws.len);
return ll + k*in->matrix->size1;
}
static int apop_wishart_draw(double *out, gsl_rng *r, apop_model *m){
/*
Translated from the Fortran by BK. Fortran comments:
C SUBROUTINE DWSHRT(D, N, NP, NNP, SB, SA)
C
C ALGORITHM AS 53 APPL. STATIST. (1972) VOL.21, NO.3
C
C Wishart variate generator. On output, SA is an upper-triangular
C matrix of size NP * NP [...]
C whose elements have a Wishart(N, SIGMA) distribution.
*/
Nullcheck_mp(m, );
int np = m->parameters->matrix->size1;
int n = m->parameters->vector->data[0];
if (!m->more) {
gsl_matrix *ccc = apop_matrix_copy(m->parameters->matrix);
gsl_linalg_cholesky_decomp(ccc);
for (int i=0; i < ccc->size1; i++) //zero out the upper diagonal
for (int j=i+1; j < ccc->size2; j++)
gsl_matrix_set(ccc, i, j, 0);
m->more = apop_matrix_to_data(ccc);
m->more_size = sizeof(apop_data);
}
apop_data *Chol = m->more;
apop_data *rmatrix = apop_data_calloc(np, np);
Staticdef(apop_model *, std_normal, apop_model_set_parameters(apop_normal, 0, 1));
//C Load diagonal elements with square root of chi-square variates
for(int i = 0; i< np; i++){
int DF = n - i;
apop_data_set(rmatrix, i, i, sqrt(gsl_ran_chisq(r, DF)));
}
for(int i = 1; i< np; i++) //off-diagonal triangles: Normals.
for(int j = 0; j< i; j++){
double ndraw;
apop_draw(&ndraw, r, std_normal);
assert (!gsl_isnan(ndraw));
apop_data_set(rmatrix, i, j, ndraw);
}
//Now find C * rand * rand' * C'
apop_data *cr = apop_dot(Chol, rmatrix);
apop_data *crr = apop_dot(cr, rmatrix, .form2='t');
apop_data *crrc = apop_dot(crr, Chol, .form2='t');
memmove(out, crrc->matrix->data, sizeof(double)*np*np);
apop_data_free(rmatrix); apop_data_free(cr);
apop_data_free(crrc); apop_data_free(crr);
return 0;
}
void draw_from_synth_model(size_t nstars, double RV, TGalacticLOSModel& gal_model, TSyntheticStellarModel& stellar_model,
TStellarData& stellar_data, TExtinctionModel& ext_model, double (&mag_limit)[5]) {
unsigned int samples = 1000;
void* gal_model_ptr = static_cast<void*>(&gal_model);
double DM_min = 0.;
double DM_max = 25.;
TDraw1D draw_DM(&log_dNdmu_draw, DM_min, DM_max, gal_model_ptr, samples, true);
double logMass_min = -0.9;
double logMass_max = 1.1;
TDraw1D draw_logMass_disk(&disk_IMF_draw, logMass_min, logMass_max, gal_model_ptr, samples, false);
TDraw1D draw_logMass_halo(&halo_IMF_draw, logMass_min, logMass_max, gal_model_ptr, samples, false);
double tau_min = 1.e6;
double tau_max = 13.e9;
TDraw1D draw_tau_disk(&disk_SFR_draw, tau_min, tau_max, gal_model_ptr, samples, false);
TDraw1D draw_tau_halo(&halo_SFR_draw, tau_min, tau_max, gal_model_ptr, samples, false);
double FeH_min = -2.5;
double FeH_max = 1.;
TDraw1D draw_FeH_disk(&disk_FeH_draw, FeH_min, FeH_max, gal_model_ptr, samples, false);
TDraw1D draw_FeH_halo(&halo_FeH_draw, FeH_min, FeH_max, gal_model_ptr, samples, false);
stellar_data.clear();
gal_model.get_lb(stellar_data.l, stellar_data.b);
gsl_rng *r;
seed_gsl_rng(&r);
double EBV, DM, logtau, logMass, FeH;
double f_halo;
bool halo, in_lib, observed;
TSED sed;
double mag[NBANDS];
double err[NBANDS];
std::cout << "Component E(B-V) DM log(Mass) log(tau) [Fe/H] g r i z y " << std::endl;
std::cout << "=============================================================================================================" << std::endl;
std::cout.flags(std::ios::left);
std::cout.precision(3);
for(size_t i=0; i<nstars; i++) {
observed = false;
while(!observed) {
// Draw E(B-V)
EBV = gsl_ran_chisq(r, 1.);
// Draw DM
DM = draw_DM();
// Draw stellar type
f_halo = gal_model.f_halo(DM);
halo = (gsl_rng_uniform(r) < f_halo);
in_lib = false;
while(!in_lib) {
if(halo) {
logMass = draw_logMass_halo();
logtau = log10(draw_tau_halo());
FeH = draw_FeH_halo();
} else {
logMass = draw_logMass_disk();
logtau = log10(draw_tau_disk());
FeH = draw_FeH_disk();
}
in_lib = stellar_model.get_sed(logMass, logtau, FeH, sed);
}
// Generate magnitudes
observed = true;
unsigned int N_nonobs = 0;
for(size_t k=0; k<NBANDS; k++) {
mag[k] = sed.absmag[k] + DM + EBV * ext_model.get_A(RV, k);
err[k] = 0.02 + 0.1*exp(mag[i]-mag_limit[i]-1.5);
mag[k] += gsl_ran_gaussian_ziggurat(r, err[k]);
// Require detection in g band and 3 other bands
if(mag[k] > mag_limit[k]) {
N_nonobs++;
if((k == 0) || N_nonobs > 1) {
observed = false;
break;
}
}
}
}
std::cout << (halo ? "halo" : "disk") << " ";
std::cout << std::setw(9) << EBV << " ";
std::cout << std::setw(9) << DM << " ";
std::cout << std::setw(9) << logMass << " ";
std::cout << std::setw(9) << logtau << " ";
std::cout << std::setw(9) << FeH << " ";
for(size_t k=0; k<NBANDS; k++) {
std::cout << std::setw(9) << mag[k] << " ";
}
std::cout << std::endl;
TStellarData::TMagnitudes mag_tmp(mag, err);
mag_tmp.obj_id = i;
mag_tmp.l = stellar_data.l;
mag_tmp.b = stellar_data.b;
stellar_data.star.push_back(mag_tmp);
}
std::cout << std::endl;
gsl_rng_free(r);
/*std::vector<bool> filled;
DM_of_P.get_filled(filled);
for(std::vector<bool>::iterator it = filled.begin(); it != filled.end(); ++it) {
std::cout << *it << std::endl;
}
*/
}
double
test_chisqnu2 (void)
{
return gsl_ran_chisq (r_global, 2.0);
}
