コード例 #1
0
ファイル: betapriorfamily.c プロジェクト: cran/BAS
double intrinsic_glm_shrinkage(SEXP hyperparams, int pmodel, double W, int Laplace ) {
  double a, b, s, r, v, theta, n, p, u, shrinkage;

  a = REAL(getListElement(hyperparams, "alpha"))[0];
  b = REAL(getListElement(hyperparams, "beta"))[0];
  s = REAL(getListElement(hyperparams, "s"))[0];
  r = REAL(getListElement(hyperparams, "r"))[0];
  n = REAL(getListElement(hyperparams, "n"))[0];

  p = (double) pmodel;
  v = (n + p + 1.0)/(p + 1);
  theta = (n + p + 1.0)/n;

  shrinkage = 1.0;
  if (p >= 1.0) {
     u = exp(-log(v)
             + lbeta((a + p) / 2.0 + 1.0, b / 2.0)
             + log(HyperTwo(b/2.0, r, (a +b+p)/2.0 + 1.0, (s+W)/(2.0*v), 1.0-theta))
             - lbeta((a+p) / 2.0, b/2.0)
             - log(HyperTwo(b/2.0, r, (a + p+ b)/2.0, (s+W)/(2.0*v), 1.0 - theta)));
    shrinkage = 1.0 - u;
  }

  return(shrinkage);
}
コード例 #2
0
ファイル: betapriorfamily.c プロジェクト: cran/BAS
double intrinsic_glm_logmarg(SEXP hyperparams, int pmodel, double W,
		       double loglik_mle, double logdet_Iintercept, int Laplace ) {
  double a, b, s, r, v, theta,n, logmarglik, p;

  a = REAL(getListElement(hyperparams, "alpha"))[0];
  b = REAL(getListElement(hyperparams, "beta"))[0];
  s = REAL(getListElement(hyperparams, "s"))[0];
  r = REAL(getListElement(hyperparams, "r"))[0];
  n = REAL(getListElement(hyperparams, "n"))[0];

  p = (double) pmodel;

  v = (n + p + 1.0)/(p + 1);
  theta = (n + p + 1.0)/n;

  logmarglik =   loglik_mle + M_LN_SQRT_2PI - 0.5* logdet_Iintercept;
  if (p >= 1.0) {
    logmarglik +=   lbeta((a + p) / 2.0, b / 2.0)
      + log(HyperTwo(b/2.0, r, (a + b + p)/2.0, (s+W)/(2.0*v), 1.0 - theta))
      -.5*p*log(v) -.5*W/v
      - lbeta(a / 2.0, b / 2.0)
      - log(HyperTwo(b/2.0, r, (a + b)/2.0, s/(2.0*v), 1.0 - theta));
  }

  return(logmarglik);
}
コード例 #3
0
ファイル: cch.c プロジェクト: sophielee1/BAS
/*--------------------------------------------------------------------------
  HyperTwo
  Function for Phi1(a,b,c,x,y)
  Assumes: 0<a<c, 0<b, y<1
  Use rule T5 if y<0.  Then use rule T1 if x>=0 or rule T2 if x<0.
--------------------------------------------------------------------------*/
double HyperTwo(double a, double b, double c, double x, double y) {
  int m=0;
  double F, zf=1.0, zfg;

  if (y<0)
    F=exp(x)*pow(1-y,-b)*HyperTwo(c-a,b,c,-x,y/(y-1));
  else {
    zfg=hyperg2F1(b,a,c,y);
    F=zfg;
    if (x<0) {
      while ((zfg/F)>FACCURACY) {
        m++;
        zf*=((c-a+m-1)/(c+m-1))*(-x/m);
        zfg=zf*hyperg2F1(b,a,c+m,y);
        F+=zfg;
      }
      F*=exp(x);
    }
    else {
      while ((zfg/F)>FACCURACY) {
        m++;
        zf*=((a+m-1)/(c+m-1))*(x/m);
        zfg=zf*hyperg2F1(b,a+m,c+m,y);
        F+=zfg;
      }
    }
  }
  return(F);
}
コード例 #4
0
ファイル: betapriorfamily.c プロジェクト: cran/BAS
double tCCH_glm_shrinkage(SEXP hyperparams, int pmodel, double W, int Laplace ) {
  double a, b, s, r, v, theta, p, shrinkage;

  a = REAL(getListElement(hyperparams, "alpha"))[0];
  b = REAL(getListElement(hyperparams, "beta"))[0];
  s = REAL(getListElement(hyperparams, "s"))[0];
  r = REAL(getListElement(hyperparams, "r"))[0];
  v = REAL(getListElement(hyperparams, "v"))[0];
  theta =  REAL(getListElement(hyperparams, "theta"))[0];

  p = (double) pmodel;

  shrinkage = 1.0;
  if (p >= 1.0) {
   shrinkage -=  exp( -log(v)
    + lbeta((a + p) / 2.0 + 1.0, b / 2.0)
    + log(HyperTwo(b/2.0, r, (a +b+p)/2.0 + 1.0, (s+W)/(2.0*v), 1.0-theta))
    - lbeta((a+p) / 2.0, b/2.0)
    - log(HyperTwo(b/2.0, r, (a + p+ b)/2.0, (s+W)/(2.0*v), 1.0 - theta)));
  }

  return(shrinkage);
}
コード例 #5
0
ファイル: cch.c プロジェクト: sophielee1/BAS
void phi1(double *a, double *b, double *c, double *x, double *y, double *phi, int *npara)
{ 
  int k;
  for (k = 0; k < *npara; k++) {
    //   if (x[k] <0) {
      /*  Since Linex system tends to report error for negative x, we
	  use the following fomular to convert it to positive value 
	  1F1(a, b, x) = 1F1(b - a, b, -x) * exp(x) */
    /*      a[k] = b[k] - a[k];
      y[k] = hyperg(a[k], b[k], -x[k])*exp(x[k]);
    }
    else {
      y[k] = hyperg(a[k], b[k], x[k]);
    }*/
    phi[k] = HyperTwo(a[k], b[k], c[k], x[k], y[k]);
  }   
}