double genchi(lua_RNG *o,double df)
/*
**********************************************************************
Generate random value of CHIsquare variable
Function
Generates random deviate from the distribution of a chisquare
with DF degrees of freedom random variable.
Arguments
df --> Degrees of freedom of the chisquare
(Must be positive)
Method
Uses relation between chisquare and gamma.
**********************************************************************
*/
{
static double genchi;
if(!(df <= 0.0)) goto S10;
fputs("DF <= 0 in GENCHI - ABORT",stderr);
fprintf(stderr,"Value of DF: %16.6E\n",df);
exit(1);
S10:
genchi = 2.0*gengam(o,1.0,df/2.0);
return genchi;
}
double CHierarchicalDP::SamplingGamma( double oldGamma )
{
// テーブルの総数を計算
int numAllTables = 0;
for(int k=0 ; k<m_dishes_k.size() ; k++ )
{
numAllTables += m_dishes_k[k].GetPopularity();
}
for(int i=0 ; i<20 ; i++ )
{
float gammaB = 0; // ガンマ関数スケールパラメータ
float gammaA = 0; // ガンマ関数形状パラメータ
int numDish = (int)m_dishes_k.size();
// ベータ分布からサンプル生成
float w = genbet( (float)oldGamma+1 , (float)numAllTables );
// 二値の分布をサンプリング
int s = (RandF() * (oldGamma + numDish)) < numDish ? 1 : 0;
gammaA = (float)(HDP_CONCPARA_PRIOR_A + numDish - s);
gammaB = (float)(HDP_CONCPARA_PRIOR_B - log(w));
// 更新
oldGamma = (double)gengam( gammaB , gammaA );
}
return oldGamma;
}
double CHierarchicalDP::SamplingLambda( double oldLambda )
{
for(int i=0 ; i<50 ; i++ )
{
float gammaB = 0; // ガンマ関数スケールパラメータ
float gammaA = 0; // ガンマ関数形状パラメータ
int numAllTables = 0;
for(int d=0 ; d<m_dataNum ; d++ )
{
int len = m_documents_d[d].length;
// ベータ分布からサンプル生成
float w = genbet( (float)oldLambda+1 , (float)len );
gammaB -= log(w);
// 二値分布からサンプリング
int s = (RandF() * (oldLambda + len)) < len ? 1 : 0;
gammaA -= s;
// テーブルの総数を計算
numAllTables += (int)m_documents_d[d].tables_t.size()-1;
}
// 事後分布のパラメタを計算
gammaA += (float)(HDP_CONCPARA_PRIOR_A + numAllTables);
gammaB += (float)HDP_CONCPARA_PRIOR_B;
// 更新
oldLambda = (double)gengam( gammaB , gammaA );
}
return oldLambda;
}
wr_errorcode_t wr_gamma_delay_filter_notify(wr_rtp_filter_t * filter, wr_event_type_t event, wr_rtp_packet_t * packet)
{
switch(event){
case TRANSMISSION_START: {
wr_gamma_delay_filter_state_t * state = calloc(1, sizeof(*state));
state->enabled = iniparser_getboolean(wr_options.output_options, "gamma_delay:enabled", 1);
state->shape = iniparser_getpositiveint(wr_options.output_options, "gamma_delay:shape", 0);
state->scale = iniparser_getpositiveint(wr_options.output_options, "gamma_delay:scale", 0);
filter->state = (void*)state;
wr_rtp_filter_notify_observers(filter, event, packet);
return WR_OK;
}
case NEW_PACKET: {
wr_gamma_delay_filter_state_t * state = (wr_gamma_delay_filter_state_t * ) (filter->state);
int delay;
if (!state->enabled){
wr_rtp_filter_notify_observers(filter, event, packet);
return WR_OK;
}
delay = (int)gengam(1/(float)state->scale, state->shape);
wr_rtp_packet_t new_packet;
wr_rtp_packet_copy(&new_packet, packet);
timeval_increment(&new_packet.lowlevel_timestamp, delay);
wr_rtp_filter_notify_observers(filter, event, &new_packet);
return WR_OK;
}
case TRANSMISSION_END: {
free(filter->state);
wr_rtp_filter_notify_observers(filter, event, packet);
return WR_OK;
}
}
}
static int rdirichlet_rng (lua_State *L) {
nl_RNG *r = getrng(L);
nl_Matrix *v, *alpha = nl_checkmatrix(L, 1);
lua_Number *ea, *ev, s;
int i;
checkrvector(L, alpha, 1);
for (i = 0, ea = alpha->data; i < alpha->size; i++, ea += alpha->stride)
luaL_argcheck(L, *ea > 0, 1, "nonpositive entry");
lua_settop(L, 2);
if (lua_isnil(L, 2))
v = nl_pushmatrix(L, 0, 1, alpha->dim, 1, alpha->size,
lua_newuserdata(L, alpha->size * sizeof(lua_Number)));
else {
v = nl_checkmatrix(L, 2);
checkrvector(L, v, 2);
luaL_argcheck(L, alpha->size == v->size, 2, "vector sizes differ");
}
/* sample gammas */
ea = alpha->data;
ev = v->data;
s = 0;
for (i = 0; i < v->size; i++) {
s += *ev = gengam(r, *ea, 1);
ev += v->stride;
ea += alpha->stride;
}
/* normalize */
for (i = 0, ev = v->data; i < v->size; i++, ev += v->stride)
*ev /= s;
return 1;
}
static int rgamma_rng (lua_State *L) {
nl_RNG *r = getrng(L);
lua_Number a = luaL_checknumber(L, 1);
lua_Number s = luaL_optnumber(L, 2, 1);
setdeviate(number, gengam(r, s, a), 3);
return 1;
}
long ignnbn(lua_RNG *o,long n,double p)
/*
**********************************************************************
GENerate Negative BiNomial random deviate
Function
Generates a single random deviate from a negative binomial
distribution.
Arguments
N --> The number of trials in the negative binomial distribution
from which a random deviate is to be generated.
P --> The probability of an event.
Method
Algorithm from page 480 of
Devroye, Luc
Non-Uniform Random Variate Generation. Springer-Verlag,
New York, 1986.
**********************************************************************
*/
{
static long ignnbn;
static double y,a,r;
/*
..
.. Executable Statements ..
*/
/*
Check Arguments
*/
if(n < 0) ftnstop("N < 0 in IGNNBN");
if(p <= 0.0F) ftnstop("P <= 0 in IGNNBN");
if(p >= 1.0F) ftnstop("P >= 1 in IGNNBN");
/*
Generate Y, a random gamma (n,(1-p)/p) variable
*/
r = (float)n;
a = p/(1.0F-p);
y = gengam(o,a,r);
/*
Generate a random Poisson(y) variable
*/
ignnbn = ignpoi(o,y);
return ignnbn;
}
int sample_lambda_prior_COST(Data_COST *i_D_COST)
{
int i,h,T,num;
double sumLambda,sumLogLambda;
double c_new,c_old,log_new,log_old,accProb,u;
double e = 0.001;
double f = 0.001;
double fac = 0.01;
sumLambda = G_ZERO;
sumLogLambda = G_ZERO;
for(h=0;h<i_D_COST->mland->n_trip;h++)
{
sumLambda += i_D_COST->mland->lambda[h];
sumLogLambda += log(i_D_COST->mland->lambda[h]);
}
T = i_D_COST->mland->n_trip;
num=1000;
c_old = i_D_COST->mland->c;
for(i=0;i<num;i++)
{
c_new = scale_proposal(c_old,fac,NULL);
log_new = -T*log(exp(gammln(c_new))) + (c_new-1)*sumLogLambda
+log(exp(gammln(e+c_new*T))) - (e+c_new*T)*log(f+sumLambda);
log_old = -T*log(exp(gammln(c_old))) + (c_old-1)*sumLogLambda
+log(exp(gammln(e+c_old*T))) - (e+c_old*T)*log(f+sumLambda);
accProb = log_new - log_old;
u = genunf(G_ZERO,G_ONE);
if(accProb > -1.0e32 && accProb < 1.0e32 && log(u) < accProb)
c_old = c_new;
}
i_D_COST->mland->c = c_old;
i_D_COST->mland->d = gengam(f+sumLambda,e+i_D_COST->mland->c*T);
return(0);
} /* end of sample_lambda_prior_COST */
void semip_gc(
//Output Arguments
double *bdraw, // draws for beta (ndraw - nomit,k) matrix
double *adraw, // draws for regional effects, a, (m,1) vector
double *pdraw, // draws for rho (ndraw - nomit,1) vector
double *sdraw, // draws for sige (ndraw - nomit,1) vector
double *rdraw, // draws for rval (ndraw - nomit,1) vector (if mm != 0)
double *vmean, // mean of vi draws (n,1) vector
double *amean, // mean of a-draws (m,1) vector
double *zmean, // mean of latent z-draws (n,1) vector
double *yhat, // mean of posterior predicted y (n,1) vector
//Input Arguments
double *y, // (n,1) lhs vector with 0,1 values
double *x, // (n,k) matrix of explanatory variables
double *W, // (m,m) weight matrix
int ndraw, // # of draws
int nomit, // # of burn-in draws to omit
int nsave, // # of draws saved (= ndraw - nomit)
int n, // # of observations
int k, // # of explanatory variables
int m, // # of regions
int *mobs, // (m,1) vector of obs numbers in each region
double *a, // (m,1) vector of regional effects
double nu, // prior parameter for sige
double d0, // prior parameter for sige
double rval, // hyperparameter r
double mm, // prior parameter for rval
double kk, // prior parameter for rval
double *detval, // (ngrid,2) matrix with [rho , log det values]
int ngrid, // # of values in detval (rows)
double *TI, // prior var-cov for beta (inverted in matlab)
double *TIc) // prior var-cov * prior mean
{
// Local Variables
int i,j,l,iter,invt,accept,rcount,cobs,obsi,zflag;
double rmin,rmax,sige,chi,ee,ratio,p,rho,rho_new;
double junk,aBBa,vsqrt,ru,rhox,rhoy,phi,awi,aw2i,bi,di;
double *z,*tvec,*e,*e0,*xb,*mn,*ys,*limit1,*limit2,*zmt;
double *bhat,*b0,*b0tmp,*v,*vv,*b1,*b1tmp,*Bpa,*rdet,*ldet,*w1;
double **xs,**xst,**xsxs,**A0,**A1,**Bpt,**Bp,**xmat,**W2;
double *Wa, **Wmat;
double c0, c1,c2;
// Allocate Matrices and Vectors
xs = dmatrix(0,n-1,0,k-1);
xst = dmatrix(0,k-1,0,n-1);
xsxs = dmatrix(0,k-1,0,k-1);
A0 = dmatrix(0,k-1,0,k-1);
A1 = dmatrix(0,m-1,0,m-1);
Bp = dmatrix(0,m-1,0,m-1);
Bpt = dmatrix(0,m-1,0,m-1);
xmat = dmatrix(0,n-1,0,k-1);
W2 = dmatrix(0,m-1,0,m-1);
Wmat = dmatrix(0,m-1,0,m-1);
z = dvector(0,n-1);
tvec = dvector(0,n-1);
e = dvector(0,n-1);
e0 = dvector(0,n-1);
xb = dvector(0,n-1);
mn = dvector(0,n-1);
ys = dvector(0,n-1);
limit1 = dvector(0,n-1);
limit2 = dvector(0,n-1);
zmt = dvector(0,n-1);
vv = dvector(0,n-1);
bhat = dvector(0,k-1);
b0 = dvector(0,k-1);
b0tmp = dvector(0,k-1);
v = dvector(0,m-1);
b1 = dvector(0,m-1);
b1tmp = dvector(0,m-1);
Bpa = dvector(0,m-1);
w1 = dvector(0,m-1);
rdet = dvector(0,ngrid-1);
ldet = dvector(0,ngrid-1);
Wa = dvector(0,m-1);
// Initializations
junk = 0.0; // Placeholder for mean in meanvar()
rho = 0.5;
sige = 1.0;
zflag = 0; // a flag for 0,1 y-values
// Initialize (z,vv,limits,tvec)
for(i=0; i<n; i++){
z[i] = y[i];
vv[i] = 1.0;
tvec[i] = 1.0;
if (y[i] == 0.0){
limit1[i] = -10000;
limit2[i] = 0.0;
zflag = 1; // we have 0,1 y-values so sample z
}else{
limit1[i] = 0.0;
limit2[i] = 10000;
}
}
// Initialize v, b1tmp, Bp
for(i=0; i<m; i++){
v[i] = 1.0;
b1tmp[i] = 1.0;
for(j=0; j<m; j++){
if (j == i){
Bp[i][j] = 1 - rho*W[i + j*m];
}else{
Bp[i][j] = - rho*W[i + j*m];
}
Wmat[i][j] = W[i + j*m];
}
}
// Parse detval into rdet and ldet vectors
// and define (rmin,rmax)
for(i=0; i<ngrid; i++){
j=0;
rdet[i] = detval[i + j*ngrid];
j=1;
ldet[i] = detval[i + j*ngrid];
}
rmin = rdet[0];
rmax = rdet[ngrid-1];
// Put x into xmat
for(i=0; i<n; i++){
for(j=0; j<k; j++)
xmat[i][j] = x[i + j*n];
}
// Compute matrices to be used for updating a-vector
if(m > 100){ // Used only for large m
for(i=0; i<m; i++){
w1[i] = 0.0; // Form w1[i]
for(j=0;j<m;j++){
w1[i] = w1[i] + (W[j + i*m]*W[j + i*m]);
}
for(j=0;j<m;j++){ // Form W2[i][*]
W2[i][j] = 0.0;
if(j != i){
for(l=0;l<m;l++){
W2[i][j] = W2[i][j] + W[l + i*m]*W[l + j*m];
}
} // Note that W2[i][i] = 0.0 by construction
}
}
} // End if(m > 10)
// ======================================
// Start the Sampler
// ======================================
for(iter=0; iter<ndraw; iter++){
// UPDATE: beta
// (1) Apply stnd devs (vsqrt) to x, z, z - tvec
for(i=0; i<n; i++){
vsqrt = sqrt(vv[i]);
zmt[i] = (z[i] - tvec[i])/vsqrt;
for(j=0; j<k; j++)
xs[i][j] = x[i + j*n]/vsqrt;
}
// (2) Construct A0 matrix
transpose(xs,n,k,xst); // form xs'
matmat(xst,k,n,xs,k,xsxs); // form xs'*xs
for(i=0; i<k; i++){ // form xs'*xs + TI
for(j=0; j<k; j++)
A0[i][j] = xsxs[i][j] + TI[i + j*k];
}
invt = inverse(A0, k); // replace A0 = inv(A0)
if (invt != 1)
mexPrintf("semip_gc: Inversion error in beta conditional \n");
// (3) Construct b0 vector
matvec(xst,k,n,zmt,b0tmp); //form xs'*zmt
for(i=0; i<k; i++){
b0tmp[i] = b0tmp[i] + TIc[i]; //form b0tmp = xs'*zmt + TIc
}
matvec(A0,k,k,b0tmp,b0); //form b0 = A0*b0tmp
// (4) Do multivariate normal draw from N(b0,A0)
normal_rndc(A0, k, bhat); // generate N(0,A0) vector
for(i=0; i<k; i++){
bhat[i] = bhat[i] + b0[i]; // add mean vector, b0
}
// (5) Now update related values:
matvec(xmat,n,k,bhat,xb); // form xb = xmat*bhat
for(i=0; i<n; i++){ // form e0 = z - x*bhat
e0[i] = z[i] - xb[i];
}
cobs = 0;
for(i=0; i<m; i++){ // form b1tmp = e0i/v[i]
obsi = mobs[i];
b1tmp[i] = 0.0;
for(j=cobs; j<cobs + obsi; j++){
b1tmp[i] = b1tmp[i] + (e0[j]/v[i]);
}
cobs = cobs + obsi;
}
// UPDATE: a
if(m <= 100){ // For small m use straight inverse
// (1) Define A1 and b1
transpose(Bp,m,m,Bpt); // form Bp'
matmat(Bpt,m,m,Bp,m,A1); // form Bp'*Bp
for(i=0; i<m; i++){ // form A1 = (1/sige)*Bp'Bp + diag(mobs/v)
for(j=0; j<m; j++){
if (j == i){
A1[i][j] = (1/sige)*A1[i][j] + ((double)mobs[i])/v[i];
}else{
A1[i][j] = (1/sige)*A1[i][j];
}
}
}
inverse(A1,m); // set A1 = inv(A1)
matvec(A1,m,m,b1tmp,b1); // form b1
// (2) Do multivariate normal draw from N(b1,A1)
normal_rndc(A1,m,a); // generate N(0,A1) vector
for(i=0; i<m; i++){
a[i] = a[i] + b1[i]; // add mean vector, b1
}
}else{ // For large m use marginal distributions
cobs = 0;
for(i=0;i<m;i++){
obsi = mobs[i];
phi = 0.0;
for(j=cobs;j<cobs+obsi;j++){
phi = phi + ((z[j] - xb[j])/v[i]); // form phi
}
awi = 0.0;
aw2i = 0.0;
for(j=0;j<m;j++){ // form awi and aw2i
aw2i = aw2i + W2[i][j]*a[j]; // (W2[i][i] = 0)
if(j != i){
awi = awi + (W[i + j*m] + W[j + i*m])*a[j];
}
}
bi = phi + (rho/sige)*awi - ((rho*rho)/sige)*aw2i;
di = (1/sige) + ((rho*rho)/sige)*w1[i] + (obsi/v[i]);
a[i] = (bi/di) + sqrt(1/di)*snorm(); // Form a[i]
cobs = cobs + obsi;
}
} // End update of a
// Compute tvec = del*a
cobs = 0;
for(i=0; i<m; i++){
obsi = mobs[i];
for(j=cobs; j<cobs + obsi; j++){
tvec[j] = a[i];
}
cobs = cobs + obsi;
}
//UPDATE: sige
matvec(Bp,m,m,a,Bpa); //form Bp*a
aBBa = 0.0; //form aBBa = a'*Bp'*Bp*a
for(i=0; i<m; i++){
aBBa = aBBa + Bpa[i]*Bpa[i];
}
chi = genchi(m + 2.0*nu);
sige = (aBBa + 2.0*d0)/chi;
//UPDATE: v (and vv = del*v)
for(i=0; i<n; i++){
e[i] = e0[i] - tvec[i]; //form e = z - x*bhat - tvec
}
cobs = 0;
for(i=0; i<m; i++){
obsi = mobs[i];
chi = genchi(rval + obsi);
ee = 0.0;
for(j=cobs; j<cobs + obsi; j++){ // form ee
ee = ee + e[j]*e[j];
}
v[i] = (ee + rval)/chi; // form v
for(j=cobs; j<cobs + obsi; j++){
vv[j] = v[i]; // form vv
}
cobs = cobs + obsi;
}
//UPDATE: rval (if necessary)
if (mm != 0.0){
rval = gengam(mm,kk);
}
//UPDATE: rho (using univariate integration)
matvec(Wmat,m,m,a,Wa); // form Wa vector
c0 = 0.0; // form a'*a
c1 = 0.0; // form a'*Wa
c2 = 0.0; // form (Wa)'*Wa
for(i=0; i<m; i++){
c0 = c0 + a[i]*a[i];
c1 = c1 + a[i]*Wa[i];
c2 = c2 + Wa[i]*Wa[i];
}
rho = draw_rho(rdet,ldet,c0,c1,c2,sige,ngrid,m,k,rho);
// (4) Update Bp matrix using new rho
for(i=0; i<m; i++){
for(j=0; j<m; j++){
if (j == i){
Bp[i][j] = 1 - rho*W[i + j*m];
}else{
Bp[i][j] = - rho*W[i + j*m];
}
}
}
//UPDATE: z
if (zflag == 1){ // skip this for continuous y-values
// (1) Generate vector of means
cobs = 0;
for(i=0; i<m; i++){
obsi = mobs[i];
for(j=cobs; j<cobs + obsi; j++){
mn[j] = xb[j] + a[i];
}
cobs = cobs + obsi;
}
// (2) Sample truncated normal for latent z values
normal_truncc(n,mn,vv,limit1,limit2,z);
// (3) Compute associated sample y vector: ys
for(i=0; i<n; i++){
if(z[i]<0){
ys[i] = 0.0;
}else{
ys[i] = 1.0;
}
}
} // end of if zflag == 1
// ===================
// Save sample draws
// ===================
if (iter > nomit-1){
pdraw[iter - nomit] = rho; //save rho-draws
sdraw[iter - nomit] = sige; //save sige-draws
if(mm != 0.0)
rdraw[iter - nomit] = rval; //save r-draws (if necessary)
for(j=0; j<k; j++)
bdraw[(iter - nomit) + j*nsave] = bhat[j]; //save beta-draws
for(i=0; i<m; i++){
vmean[i] = vmean[i] + v[i]/((double) (nsave)); //save mean v-draws
adraw[(iter - nomit) + i*nsave] = a[i]; //save a-draws
amean[i] = amean[i] + a[i]/((double) (nsave)); //save mean a-draws
}
for(i=0; i<n; i++){
zmean[i] = zmean[i] + z[i]/((double) (nsave)); //save mean z-draws
yhat[i] = yhat[i] + mn[i]/((double) (nsave)); //save mean y-values
}
}
} // End iteration loop
// ===============================
// END SAMPLER
// ===============================
// Free up allocated vectors
free_dmatrix(xs,0,n-1,0);
free_dmatrix(xst,0,k-1,0);
free_dmatrix(xsxs,0,k-1,0);
free_dmatrix(A0,0,k-1,0);
free_dmatrix(A1,0,m-1,0);
free_dmatrix(Bp,0,m-1,0);
free_dmatrix(Bpt,0,m-1,0);
free_dmatrix(W2,0,m-1,0);
free_dmatrix(xmat,0,n-1,0);
free_dmatrix(Wmat,0,m-1,0);
free_dvector(z,0);
free_dvector(tvec,0);
free_dvector(e,0);
free_dvector(e0,0);
free_dvector(xb,0);
free_dvector(mn,0);
free_dvector(ys,0);
free_dvector(limit1,0);
free_dvector(limit2,0);
free_dvector(zmt,0);
free_dvector(vv,0);
free_dvector(bhat,0);
free_dvector(b0,0);
free_dvector(b0tmp,0);
free_dvector(v,0);
free_dvector(b1,0);
free_dvector(b1tmp,0);
free_dvector(Bpa,0);
free_dvector(rdet,0);
free_dvector(ldet,0);
free_dvector(w1,0);
free_dvector(Wa,0);
} // End of semip_gc
