void fbst_loginorm(gsl_rng *r, gsl_vector_uint *x, gsl_vector_uint *sums, double alpha, double beta, double *_ev,double *_err, FBSTConfig *config) { size_t i,j; double mean; double var; double a,b; assert(x->size == sums->size); gsl_vector *means=gsl_vector_alloc(x->size); gsl_vector *sd=gsl_vector_alloc(x->size); for(i=0;i<x->size;i++) { a=ELT(x,i)+alpha; b=ELT(sums,i)+beta-a; mean=gsl_sf_psi(a)-gsl_sf_psi(b); var=gsl_sf_psi_1(a)+gsl_sf_psi_1(b); printf("x%i=N(%lg %lg)\n",i,mean,var); gsl_vector_set(means,i,mean); gsl_vector_set(sd,i,var); } fbst_normal(r,means,sd,_ev,_err,config); gsl_vector_free(means); gsl_vector_free(sd); }
void binom_transform (const double* rs, const double* fq, double* out) { double r=rs[0]; double s=rs[1]; double f=fq[0]; double q=fq[1]; double E = gsl_sf_psi(r) - gsl_sf_psi(s); double V = gsl_sf_psi_1(r) + gsl_sf_psi_1(s); out[0] = E - f; out[1] = V - q; // Rprintf("r=%g, s=%g, f=%g, q=%g, out=%g, %g\n", r, s, f, q, out[0], out[1]); }
static void hessian(gsl_matrix* ptHessian, const double* adLambda, const struct data_t *data) { const int S = data->S, N = data->N, *aanX = data->aanX; const double *adPi = data->adPi; int i = 0, j = 0; double adAlpha[S], adAJK[S], adCJK[S], adAJK0[S], adCJK0[S]; double dCK0 = 0.0, dAK0; double dCSum, dAlphaSum = 0.0, dW = 0.0, dCK = 0.0, dAK; for (j = 0; j < S; j++) { adAlpha[j] = exp(adLambda[j]); dAlphaSum += adAlpha[j]; adAJK0[j] = adAJK[j] = adCJK0[j] = adCJK[j] = 0.0; const double dPsiAlpha = gsl_sf_psi(adAlpha[j]); const double dPsi1Alpha = gsl_sf_psi_1(adAlpha[j]); for (i = 0; i < N; i++) { const int n = aanX[j * N + i]; adCJK0[j] += adPi[i] * n ? gsl_sf_psi(adAlpha[j] + n) : dPsiAlpha; adAJK0[j] += adPi[i] * dPsiAlpha; adCJK[j] += adPi[i] * n ? gsl_sf_psi_1(adAlpha[j] + n): dPsi1Alpha; adAJK[j] += adPi[i] * dPsi1Alpha; } } for (i = 0; i < N; i++) { dW += adPi[i]; dCSum = 0.0; for (j = 0; j < S; j++) dCSum += adAlpha[j] + aanX[j * N + i]; dCK += adPi[i]*gsl_sf_psi_1(dCSum); dCK0 += adPi[i]*gsl_sf_psi(dCSum); } dAK = dW * gsl_sf_psi_1(dAlphaSum); dAK0 = dW * gsl_sf_psi(dAlphaSum); for (i = 0; i < S; i++) for (j = 0; j < S; j++) { double dVal = 0.0; if (i == j) { double dG1 = -adAlpha[i] * (dAK0 - dCK0 + adCJK0[i] - adAJK0[i]); double dG2 = -adAlpha[i] * adAlpha[i]*(dAK - dCK + adCJK[i] - adAJK[i]); double dG3 = adAlpha[i]*GAMMA_NU; dVal = dG1 + dG2 + dG3; } else dVal = -adAlpha[i] * adAlpha[j] * (dAK - dCK); gsl_matrix_set(ptHessian, i, j, dVal); } }
double NBinGlm::getfAfAdash(double k0, unsigned int id, unsigned int limit) { unsigned int i, it=0; double sum=1, num=0, k; double y, m, dl, ddl, tol; double phi, dl_dphi, d2l_dphi2, del_phi; if (k0==0) { for (i=0; i<nRows; i++) { y = gsl_matrix_get(Yref, i, id); m = gsl_matrix_get(Mu, i, id); if (m>0) { sum = sum+(y/m-1)*(y/m-1); num = num+1; } } k = num/sum; if (num==0) printf("num=0\n"); } else k=k0; k = MAX(k, mintol); phi = 1/k; while ( it<limit ) { it++; dl=nRows*(1+log(k)-gsl_sf_psi(k)); ddl=nRows*(gsl_sf_psi_1(k)-1/k); for ( i=0; i<nRows; i++ ) { y = gsl_matrix_get(Yref, i, id); m = gsl_matrix_get(Mu, i, id); dl = dl + gsl_sf_psi(y+k)-log(m+k)-(y+k)/(m+k); ddl = ddl - gsl_sf_psi_1(y+k)+2/(m+k)-(y+k)/((m+k)*(m+k)); } dl_dphi = - exp(2*log(k))*dl; d2l_dphi2 = 2*exp(3*log(k))*dl + exp(4*log(k))*ddl; if (ABS(ddl) < mintol) ddl = GSL_SIGN(ddl)*mintol; del_phi = dl_dphi/ABS(d2l_dphi2); tol = ABS(del_phi*dl_dphi); if (tol<eps) break; phi = phi + del_phi; if (phi<0) {k=0; break;} k = 1/MAX(ABS(phi),mintol); if (k>maxth) break; } return k; }
double NBinGlm::thetaML(double k0, unsigned int id, unsigned int limit) { // equivalent to theta.ml() in MASS // Note that theta here is the dispersion parameter // So phi = 1/theta; unsigned int i, it=0; double del=1, sum=1, num=0, k; double y, m, dl, ddl, tol; if (k0==0) { for (i=0; i<nRows; i++) { y = gsl_matrix_get(Yref, i, id); m = gsl_matrix_get(Mu, i, id); if (m>0) { sum = sum+(y/m-1)*(y/m-1); num = num+1; } } k = num/sum; } else k=k0; k = MAX(k, mintol); while ( it<=limit ) { it++; k = ABS(k); dl=nRows*(1+log(k)-gsl_sf_psi(k)); ddl=nRows*(gsl_sf_psi_1(k)-1/k); for ( i=0; i<nRows; i++ ) { y = gsl_matrix_get(Yref, i, id); m = gsl_matrix_get(Mu, i, id); dl = dl + gsl_sf_psi(y+k)-log(m+k)-(y+k)/(m+k); ddl = ddl - gsl_sf_psi_1(y+k)+2/(m+k)-(y+k)/((m+k)*(m+k)); } if (ABS(ddl) < mintol) ddl = GSL_SIGN(ddl)*mintol; del = dl/ABS(ddl); tol = ABS(del*dl); if (tol<eps) break; k = k+del; // Normal Newton use - instead of + for -ddl if (k>maxth) break; if (k<0) { k = 0; break; } } // if (k<0) k=0; return k; }
int binom_transform_df(const gsl_vector* x, void* p, gsl_matrix* J) { double r = gsl_vector_get(x, 0); double s = gsl_vector_get(x, 1); double df00 = gsl_sf_psi_1(r); double df01 = -1.0 * gsl_sf_psi_1(s); double df10 = gsl_sf_psi_n(2, r); double df11 = gsl_sf_psi_n(2, s); gsl_matrix_set(J, 0, 0, df00); gsl_matrix_set(J, 0, 1, df01); gsl_matrix_set(J, 1, 0, df10); gsl_matrix_set(J, 1, 1, df11); return GSL_SUCCESS; }
void gr_KL_V_nu_g (const gsl_vector *v_V_nu_g, void *null, gsl_vector *df) { int i = *params->i; //, j, d = *params->d; int g, G = *params->G; double tmpsum = 0.0, tmp; int N = *params->N; double KL; double V_nu_g = gsl_vector_get(v_V_nu_g, 0); tmp = 0.0; for (g = 0; g < G; g++) if (g!=*params->g) tmp += params->V_nu[g]; for (i = 0; i < SUBSET; i++) tmpsum = tmpsum + params->V_lambda[*params->g * N + i] * (gsl_sf_psi_1 (V_nu_g) - gsl_sf_psi_1 (tmp+V_nu_g)); KL = tmpsum - gsl_sf_psi (tmp+V_nu_g) - gsl_sf_psi (params->nu[*params->g]) - V_nu_g * gsl_sf_psi_1 (V_nu_g) + params->nu[*params->g] * gsl_sf_psi_1 (V_nu_g); gsl_vector_set(df, 0, -KL); return; }
void gr_KL_V_alpha_g (const gsl_vector *v_V_alpha_g, void *null, gsl_vector *df) { int i = *params->i; int g = *params->g; double tmpsum = 0.0, tmp; int N = *params->N; int d; double KL; double V_alpha_g = gsl_vector_get(v_V_alpha_g, 0); for (i = 0; i < SUBSET; i++) { tmp = 0.0; for (d=0; d<*params->D; d++) tmp += pow(params->V_z[i * *params->D + d] - params->V_eta[g * *params->D + d], 2.0); tmpsum += params->V_lambda[*params->g * N + i] * (*params->D* *params->inv_sigma02* gsl_sf_psi_1(0.5* *params->inv_sigma02*V_alpha_g)- 0.5* *params->inv_sigma02*(params->V_sigma2[i]+params->V_omega2[g]+tmp)); } KL = tmpsum + (0.5*(V_alpha_g-params->alpha[*params->g])* gsl_sf_psi_1(0.5*V_alpha_g));// - //gsl_sf_psi(0.5*V_alpha_g)) + gsl_sf_psi(0.5*V_alpha_g)/lgamma(0.5*V_alpha_g); gsl_vector_set(df, 0, -KL); return; }
//------------------------------------------------------------------------------ /// Trigamma function \f$ \psi^{(1)}(x) \f$ inline double psi1(const double x) { return gsl_sf_psi_1(x); }
double trigamma(double x){ return gsl_sf_psi_1(x); }