示例#1
0
void BAFT_LNsurv_update_sigSq(gsl_vector *yL,
                              gsl_vector *yU,
                              gsl_vector *yU_posinf,
                              gsl_vector *c0,
                              gsl_vector *c0_neginf,
                              gsl_matrix *X,
                              gsl_vector *y,
                              gsl_vector *beta,
                              double beta0,
                              double *sigSq,
                              double a_sigSq,
                              double b_sigSq,
                              double sigSq_prop_var,
                              int *accept_sigSq)
{
    int i, u;
    double eta, loglh, loglh_prop, logR, gamma_prop, sigSq_prop;
    double logprior, logprior_prop;
    
    int n = X -> size1;
    gsl_vector *xbeta = gsl_vector_calloc(n);
    
    loglh = 0;
    loglh_prop = 0;
    gamma_prop = rnorm(log(*sigSq), sqrt(sigSq_prop_var));
    sigSq_prop = exp(gamma_prop);
    gsl_blas_dgemv(CblasNoTrans, 1, X, beta, 0, xbeta);
    
    for(i=0;i<n;i++)
    {
        eta = beta0 + gsl_vector_get(xbeta, i);
        if(gsl_vector_get(c0_neginf, i) == 0)
        {
            loglh += dnorm(gsl_vector_get(y, i), eta, sqrt(*sigSq), 1) - pnorm(gsl_vector_get(c0, i), eta, sqrt(*sigSq), 0, 1);
            loglh_prop += dnorm(gsl_vector_get(y, i), eta, sqrt(sigSq_prop), 1) - pnorm(gsl_vector_get(c0, i), eta, sqrt(sigSq_prop), 0, 1);
        }else
        {
            loglh += dnorm(gsl_vector_get(y, i), eta, sqrt(*sigSq), 1);
            loglh_prop += dnorm(gsl_vector_get(y, i), eta, sqrt(sigSq_prop), 1);
        }        
    }
    
    logprior = (-a_sigSq-1)*log(*sigSq)-b_sigSq /(*sigSq);
    logprior_prop = (-a_sigSq-1)*log(sigSq_prop)-b_sigSq/sigSq_prop;
    
    logR = loglh_prop - loglh + logprior_prop - logprior + gamma_prop - log(*sigSq);
    
    u = log(runif(0, 1)) < logR;
    
    if(u == 1)
    {
        *sigSq = sigSq_prop;
        *accept_sigSq += 1;
    }
    
    gsl_vector_free(xbeta);
    return;
}
示例#2
0
文件: pwiener.c 项目: cran/RWiener
double Fs0_lower(double q, double a, double w, int K)
{
  double F=0;
  for(int k=K; k>=0; k--) {
    F = F - pnorm((-2*k - 2 + w)*a/sqrt(q),0,1,1,0) + pnorm((-2*k - w)*a/sqrt(q),0,1,1,0);
  }

  return 2*F;
}
示例#3
0
  //----------------------------------------------------------------------
  std::pair<double, double> BinomialLogitCltDataImputer::impute_large_sample(
      RNG &rng, double number_of_trials, double number_of_successes,
      double linear_predictor) const {
    double information = 0.0;
    const Vector &mixing_weights(mixture_approximation.weights());
    const Vector &sigma(mixture_approximation.sigma());
    double negative_logit_support = plogis(0, linear_predictor, 1, true);
    double positive_logit_support = plogis(0, linear_predictor, 1, false);
    Vector p0 = mixing_weights / negative_logit_support;
    Vector p1 = mixing_weights / positive_logit_support;
    for (int m = 0; m < mixture_approximation.dim(); ++m) {
      p0[m] *= pnorm(0, linear_predictor, sigma[m], true);
      p1[m] *= pnorm(0, linear_predictor, sigma[m], false);
    }

    // p0 is the probability distribution over the mixture component
    // indicators for the failures.  N0 is the count of the number of
    // failures belonging to each mixture component.
    std::vector<int> N0 =
        rmultinom_mt(rng, number_of_trials - number_of_successes, p0 / sum(p0));

    // p1 is the probability distribution over the mixture component
    // indicators for the successes.  N1 is the count of the number
    // of successes in each mixture component.
    std::vector<int> N1 = rmultinom_mt(rng, number_of_successes, p1 / sum(p1));

    double simulation_mean = 0;
    double simulation_variance = 0;
    for (int m = 0; m < N0.size(); ++m) {
      int total_obs = N0[m] + N1[m];
      if (total_obs == 0) {
        continue;
      }
      double sigsq = square(sigma[m]);
      double sig4 = square(sigsq);
      information += total_obs / sigsq;
      double truncated_normal_mean;
      double truncated_normal_variance;
      double cutpoint = 0;
      if (N0[m] > 0) {
        trun_norm_moments(linear_predictor, sigma[m], cutpoint, false,
                          &truncated_normal_mean, &truncated_normal_variance);
        simulation_mean += N0[m] * truncated_normal_mean / sigsq;
        simulation_variance += N0[m] * truncated_normal_variance / sig4;
      }
      if (N1[m] > 0) {
        trun_norm_moments(linear_predictor, sigma[m], cutpoint, true,
                          &truncated_normal_mean, &truncated_normal_variance);
        simulation_mean += N1[m] * truncated_normal_mean / sigsq;
        simulation_variance += N1[m] * truncated_normal_variance / sig4;
      }
    }
    double information_weighted_sum =
        rnorm_mt(rng, simulation_mean, sqrt(simulation_variance));
    return std::make_pair(information_weighted_sum, information);
  }
示例#4
0
gnm_float
dsnorm (gnm_float x, gnm_float shape, gnm_float location, gnm_float scale, gboolean give_log)
{
    if (shape == 0.)
        return dnorm (x, location, scale, give_log);
    else if (give_log)
        return gnm_log (2.) + dnorm (x, location, scale, TRUE) + pnorm (shape * x, shape * location, scale, TRUE, TRUE);
    else
        return 2 * dnorm (x, location, scale, FALSE) * pnorm (shape * x, location/shape, scale, TRUE, FALSE);
}
示例#5
0
  double pig(double x, double mu, double lambda, bool logscale){
    if(x <= 0) return logscale ? negative_infinity() :  0;
    if(mu <= 0) throw_exception<std::runtime_error>("mu <= 0 in pig");
    if(lambda <= 0) throw_exception<std::runtime_error>("lambda <= 0 in pig");

    double rlx = sqrt(lambda/x);
    double xmu = x/mu;
    double ans = pnorm(rlx * (xmu -1)) + exp(2*lambda/mu) * pnorm(-rlx*(xmu + 1));
    return logscale ? log(ans) : ans;
  }
示例#6
0
文件: rand.c 项目: nickbloom/MNP
/* Sample from a univariate truncated Normal distribution 
   (truncated both from above and below): choose either inverse cdf
   method or rejection sampling method. For rejection sampling, 
   if the range is too far from mu, it uses standard rejection
   sampling algorithm with exponential envelope function. */ 
double TruncNorm(
		 double lb,  /* lower bound */ 
		 double ub,  /* upper bound */
		 double mu,  /* mean */
		 double var, /* variance */
		 int invcdf  /* use inverse cdf method? */
		 ) {
  
  double z;
  double sigma = sqrt(var);
  double stlb = (lb-mu)/sigma;  /* standardized lower bound */
  double stub = (ub-mu)/sigma;  /* standardized upper bound */
  if(stlb > stub)
    error("TruncNorm: lower bound is greater than upper bound\n");
  if(stlb == stub) {
    warning("TruncNorm: lower bound is equal to upper bound\n");
    return(stlb*sigma + mu);
  }
  if (invcdf) {  /* inverse cdf method */
    z = qnorm(runif(pnorm(stlb, 0, 1, 1, 0), pnorm(stub, 0, 1, 1, 0)),
	      0, 1, 1, 0); 
  }
  else { /* rejection sampling method */
    double tol=2.0;
    double temp, M, u, exp_par;
    int flag=0;  /* 1 if stlb, stub <-tol */
    if(stub<=-tol){
      flag=1;
      temp=stub;
      stub=-stlb;
      stlb=-temp;
    }
    if(stlb>=tol){
      exp_par=stlb;
      while(pexp(stub,1/exp_par,1,0) - pexp(stlb,1/exp_par,1,0) < 0.000001) 
	exp_par/=2.0;
      if(dnorm(stlb,0,1,1) - dexp(stlb,1/exp_par,1) >=
	 dnorm(stub,0,1,1) - dexp(stub,1/exp_par,1)) 
	M=exp(dnorm(stlb,0,1,1) - dexp(stlb,1/exp_par,1));
      else
	M=exp(dnorm(stub,0,1,1) - dexp(stub,1/exp_par,1));
      do{ 
	u=unif_rand();
	z=-log(1-u*(pexp(stub,1/exp_par,1,0)-pexp(stlb,1/exp_par,1,0))
	       -pexp(stlb,1/exp_par,1,0))/exp_par;
      }while(unif_rand() > exp(dnorm(z,0,1,1)-dexp(z,1/exp_par,1))/M );  
      if(flag==1) z=-z;
    } 
    else{ 
      do z=norm_rand();
      while( z<stlb || z>stub ); 
    }
  }
  return(z*sigma + mu); 
}
示例#7
0
void BAFT_LNsurv_update_beta0(gsl_vector *yL,
                              gsl_vector *yU,
                              gsl_vector *yU_posinf,
                              gsl_vector *c0,
                              gsl_vector *c0_neginf,
                              gsl_matrix *X,
                              gsl_vector *y,
                              gsl_vector *beta,
                              double *beta0,
                              double sigSq,
                              double beta0_prop_var,
                              int *accept_beta0)
{
    int i, u;
    double eta, eta_prop, loglh, loglh_prop, logR, beta0_prop, logprior, logprior_prop;
    
    int n = X -> size1;
    
    gsl_vector *xbeta = gsl_vector_calloc(n);
    
    loglh = 0;
    loglh_prop = 0;
    beta0_prop = rnorm(*beta0, sqrt(beta0_prop_var));
    gsl_blas_dgemv(CblasNoTrans, 1, X, beta, 0, xbeta);
    
    for(i=0;i<n;i++)
    {
        eta = *beta0 + gsl_vector_get(xbeta, i);
        eta_prop = beta0_prop + gsl_vector_get(xbeta, i);
        if(gsl_vector_get(c0_neginf, i) == 0)
        {
            loglh += dnorm(gsl_vector_get(y, i), eta, sqrt(sigSq), 1) - pnorm(gsl_vector_get(c0, i), eta, sqrt(sigSq), 0, 1);
            loglh_prop += dnorm(gsl_vector_get(y, i), eta_prop, sqrt(sigSq), 1) - pnorm(gsl_vector_get(c0, i), eta_prop, sqrt(sigSq), 0, 1);
        }else
        {
            loglh += dnorm(gsl_vector_get(y, i), eta, sqrt(sigSq), 1);
            loglh_prop += dnorm(gsl_vector_get(y, i), eta_prop, sqrt(sigSq), 1);
        }        
    }
    
    logprior = dnorm(*beta0, 0, pow(10,6)*sqrt(sigSq), 1);
    logprior_prop = dnorm(beta0_prop, 0, pow(10,6)*sqrt(sigSq), 1);
    
    logR = loglh_prop - loglh;
    u = log(runif(0, 1)) < logR;
    if(u == 1)
    {
        *beta0 = beta0_prop;
        *accept_beta0 += 1;
    }
    
    gsl_vector_free(xbeta);
    return;
}
示例#8
0
void truncatedRat(double *old, double *sd, double *low, double *high, double *newvalue, double *ratio) {
  double lowlimold, upplimold, lowlimnew, upplimnew, plowold, puppold, plownew, puppnew;
  lowlimold = (*low - *old)/ *sd;
  upplimold = (*high - *old)/ *sd;
  lowlimnew = (*low - *newvalue)/ *sd;
  upplimnew = (*high - *newvalue)/ *sd;
  plowold = pnorm(lowlimold,0.0,1.0,1,0);
  puppold = pnorm(upplimold,0.0,1.0,1,0);
  plownew = pnorm(lowlimnew,0.0,1.0,1,0);
  puppnew = pnorm(upplimnew,0.0,1.0,1,0);
  *ratio = (puppold - plowold)/(puppnew - plownew);
}
示例#9
0
文件: extra.c 项目: GNOME/gnumeric
gnm_float
dsnorm (gnm_float x, gnm_float shape, gnm_float location, gnm_float scale, gboolean give_log)
{
	if (gnm_isnan (x) || gnm_isnan (shape) || gnm_isnan (location) || gnm_isnan (scale))
		return gnm_nan;

	if (shape == 0.)
		return dnorm (x, location, scale, give_log);
	else if (give_log)
		return M_LN2gnum + dnorm (x, location, scale, TRUE) + pnorm (shape * x, shape * location, scale, TRUE, TRUE);
	else
		return 2 * dnorm (x, location, scale, FALSE) * pnorm (shape * x, location/shape, scale, TRUE, FALSE);
}
示例#10
0
double dcutpoints(const cs *liab, double *yP, int *observed, int start,int finish, double *oldcutpoints, double *newcutpoints, int stcutpoints, int ncutpoints, double sdcp, double sdl)
{
    int i,j,w;
    double llik = 0.0;

    for (j = 2 ; j < (ncutpoints-2); j++){
        llik += log(pnorm(oldcutpoints[stcutpoints+j+1]-oldcutpoints[j], 0.0, sdcp, TRUE,FALSE)-pnorm(newcutpoints[stcutpoints+j-1]-oldcutpoints[j], 0.0, sdcp, TRUE,FALSE));
        llik -= log(pnorm(newcutpoints[stcutpoints+j+1]-newcutpoints[j], 0.0, sdcp, TRUE,FALSE)-pnorm(oldcutpoints[stcutpoints+j-1]-newcutpoints[j], 0.0, sdcp, TRUE,FALSE));
    }

    llik += log(1.0-pnorm(newcutpoints[stcutpoints+ncutpoints-3]-oldcutpoints[stcutpoints+ncutpoints-2], 0.0, sdcp, TRUE,FALSE));
    llik -= log(1.0-pnorm(oldcutpoints[stcutpoints+ncutpoints-3]-newcutpoints[stcutpoints+ncutpoints-2], 0.0, sdcp, TRUE,FALSE));

    for (i = start ; i < finish; i++){
        w = yP[i];
        if(w>1 && observed[i]==1){
          if(w==(ncutpoints-1)){
            llik += log(1.0-pnorm(newcutpoints[stcutpoints+w-1], liab->x[i], sdl, TRUE,FALSE));
            llik -= log(1.0-pnorm(oldcutpoints[stcutpoints+w-1], liab->x[i], sdl, TRUE,FALSE));
          }else{
            llik += log(pnorm(newcutpoints[stcutpoints+w], liab->x[i], sdl, TRUE,FALSE)-pnorm(newcutpoints[stcutpoints+w-1], liab->x[i], sdl, TRUE,FALSE));
            llik -= log(pnorm(oldcutpoints[stcutpoints+w], liab->x[i], sdl, TRUE,FALSE)-pnorm(oldcutpoints[stcutpoints+w-1], liab->x[i], sdl, TRUE,FALSE));
          }
        }
    }
    return llik;
}
示例#11
0
文件: sir.c 项目: kingaa/pomp
void _sir_binom_dmeasure (double *lik, double *y, double *x, double *p, int give_log,
			  int *obsindex, int *stateindex, int *parindex, int *covindex,
			  int ncovars, double *covars, double t) {
  double mean, sd;
  double f;
  mean = CASE*RHO;
  sd = sqrt(CASE*RHO*(1-RHO));
  if (REPORTS > 0) {
    f = pnorm(REPORTS+0.5,mean,sd,1,0)-pnorm(REPORTS-0.5,mean,sd,1,0);
  } else {
    f = pnorm(REPORTS+0.5,mean,sd,1,0);
  }
  *lik = (give_log) ? log(f) : f;
}
示例#12
0
文件: extra.c 项目: GNOME/gnumeric
gnm_float
psnorm (gnm_float x, gnm_float shape, gnm_float location, gnm_float scale, gboolean lower_tail, gboolean log_p)
{
	gnm_float result, h;

	if (gnm_isnan (x) || gnm_isnan (shape) ||
	    gnm_isnan (location) || gnm_isnan (scale))
		return gnm_nan;

	if (shape == 0.)
		return pnorm (x, location, scale, lower_tail, log_p);

	/* Normalize */
	h = (x - location) / scale;

	/* Flip to a lower-tail problem.  */
	if (!lower_tail) {
		h = -h;
		shape = -shape;
		lower_tail = !lower_tail;
	}

	if (gnm_abs (shape) < 10) {
		gnm_float s = pnorm (h, 0, 1, lower_tail, FALSE);
		gnm_float t = 2 * gnm_owent (h, shape);
		result = s - t;
	} else {
		/*
		 * Make use of this result for Owen's T:
		 *
		 * T(h,a) = .5N(h) + .5N(ha) - N(h)N(ha) - T(ha,1/a)
		 */
		gnm_float s = pnorm (h * shape, 0, 1, TRUE, FALSE);
		gnm_float u = gnm_erf (h / M_SQRT2gnum);
		gnm_float t = 2 * gnm_owent (h * shape, 1 / shape);
		result = s * u + t;
	}

	/*
	 * Negatives can occur due to rounding errors and hopefully for no
	 * other reason.
	 */
	result= CLAMP (result, 0.0, 1.0);

	if (log_p)
		return gnm_log (result);
	else
		return result;
}
示例#13
0
文件: pswald.c 项目: yeagle/swald
double p_swald(double t, double alpha, double nu, double theta, int lower_tail, int log_p)
{
    double p;
    double x;

    if(log_p)
      x = exp(t);
    else
      x = t;

    p = pnorm((nu*(x-theta)-alpha) / sqrt((x-theta)), 0,1,1,0) + 
        exp(2*alpha*nu) * pnorm(-(nu*(x-theta)+alpha) / sqrt((x-theta)), 0,1,1,0);
    
    return (lower_tail ? p : 1-p);
}
示例#14
0
文件: vector.cpp 项目: rashaw1/LinAlg
// Get the angle between two vectors
double angle(const Vector& u, const Vector& w)
{
  // Get the magnitudes of the vectors
  double unorm = pnorm(u);
  double wnorm = pnorm(w);
  // Get the dot product
  double dprod = inner(u, w);
  // Use the cosine rule
  // but make sure neither is a zero vector
  double rval = 0.0;
  if(dprod > 1E-12){
    rval = std::acos(dprod/(unorm*wnorm));
  }
  return rval;
}
示例#15
0
文件: pwiener.c 项目: cran/RWiener
double exp_pnorm(double a, double b)
{
  double r=0;
  if (R_IsNaN(r) && b < -5.5) r = 1/sqrt(2) * exp(a - b*b/2) * (0.5641882/b/b/b - 1/b/sqrt(M_PI));
  else r = exp(a) * pnorm(b,0,1,1,0);
  return r;
}
示例#16
0
void betaHyperObjectiveGr(int n, double * par, double * gr, void * ex) {
    // m is location parameter, tau is log of precision parameter
    const double m(par[0]), tau(par[1]);
    // extract objective parameters
    double * input = static_cast<double *>(ex);
    const double beta1_sum(input[0]);
    const double beta1_sqr_sum(input[1]);
    const double P(input[2]);

    const double l1(input[3]);
    const double s1(input[4]);
    const double m_bar(input[5]);
    const double nu_m(input[6]);

    double g_m, g_tau;
    const double log_inv_mills = dnorm(m * exp(.5 * tau), 0, 1, /* give_log */ 1) -
            pnorm(m * exp(.5 * tau), 0, 1, /* lower_tail */ 1, /* give_log */ 1);
    g_m = - P * exp(.5 * tau + log_inv_mills);
    g_m += exp(tau) * (beta1_sum - m * P);
    g_m += nu_m * (m_bar - m);

    g_tau = - P * m * .5 * exp(.5 * tau + log_inv_mills);
    g_tau += - exp(tau) * .5 * (beta1_sqr_sum - 2.0 * m * beta1_sum + P * m * m);
    g_tau += - exp(tau) * l1 + (s1 - 1.0) + P * .5;

    gr[0] = - g_m;
    gr[1] = - g_tau;
}
示例#17
0
// Compute the gradient vector of the conditional log likelihood for a Gaussian-Binary model :
void Grad_Cond_Bin(double rho,double pij, double p,int *flag, double *gradcor, double *grad,
		   int *npar, double *nuis, double *thr, double u, double v)
{
  // Initialization variables:
  double dpij=0.0, dij=0.0, rvar=0.0, dpdm=0.0, f=0.0;
  double q1=0.0, q2=0.0, q3=0.0, sh=0.0, vario=0.0, z=0;
  int h=0, i=0, j=0;
  //init variables:
  z=(nuis[0]-*thr)/sqrt(nuis[2]+nuis[1]);
  rvar=nuis[2]/(nuis[2]+nuis[1]);
  //set derivatives components:
  q1=dnorm(z,0,1,0);//stand normal pdf
  q2=pnorm(z*sqrt((1-rvar*rho)/(1+rvar*rho)),0,1,1,0);// stand norm cdf
  q3=d2norm(z,z,rvar*rho);// biv stand norm pdf
  //derivatives:
  dpdm=q1/sqrt(nuis[2]+nuis[1]);/*dp/dmu*/
  dpij=2*dpdm*q2;/*dpij/dmu*/
  f=-(0.5*(nuis[0]-*thr)*dpdm)/(nuis[2]+nuis[1]);/* dp/dsill*/
  dij=2*f*q2;/* dpij/dsill*/
  vario=2*(p-pij);//variogramma binario!!!
  sh=1/(1-2*p+pij);
  // Derivative of the difference respect with the mean
  if(flag[0]==1) { grad[i]=(dpij-2*dpdm)*(1-((u+v)*nij(dpij,dpdm,pij,p)+
					   (u*v)*mij(dpij,dpdm,pij,p)))*sh+dpdm*(1-(u+v)/(2*p))/(1-p); i++; }
  // Derivative of the difference respect with the nugget
  if(flag[1]==1) { grad[i]=1; i++; }
  // Derivative of the difference respect with the sill
  if(flag[2]==1) { grad[i]=(dij-2*f)*(1-((u+v)*nij(dij,f,pij,p)+
					 (u*v)*mij(dij,f,pij,p)))*sh+f*(1-(u+v)/(2*p))/(1-p); i++; }
  // Derivatives with respect to the correlation parameters
  for(j=i;j<*npar;j++) { grad[j]=gradcor[j]*q3*rvar*(1-((u+v)*2*(p-1)/vario +
                                                (u*v)*2*(pij-2*pow(p,2)+p)/(vario*pij)))*sh; h++; }

  return;
}
示例#18
0
SEXP pvaluecombine( SEXP RpVec, SEXP Rmethod ) {
	int k = length(RpVec);
	const char * method = CHAR(STRING_ELT(Rmethod, 0));
	
	SEXP Rcmbdpvalue = PROTECT(allocVector(REALSXP, 1));
	memset(REAL(Rcmbdpvalue), 0.0, sizeof(double));
	
	double * cmbdpvalue = REAL(Rcmbdpvalue);
	if (!strcmp(method, "fisher")) {
		for (int i=0; i<k; i++) {
			*cmbdpvalue += log(REAL(RpVec)[i]);
		}
		*cmbdpvalue = 1 - pchisq(-2 * *cmbdpvalue, 2*k, 1, 0);
	} else if (!strcmp(method, "normal") || !strcmp(method, "stouffer")) {
		for (int i=0; i<k; i++) {
			*cmbdpvalue += qnorm(REAL(RpVec)[i], 0.0, 1.0, 1, 0);
		}
		*cmbdpvalue = *cmbdpvalue / sqrt(k);
		*cmbdpvalue = pnorm(*cmbdpvalue, 0.0, 1.0, 1, 0);
	} else if (!strcmp(method, "min") || !strcmp(method, "tippett")) {
		*cmbdpvalue = REAL(RpVec)[0];
		for (int i=1; i<k; i++) {
			*cmbdpvalue = fmin2(*cmbdpvalue, REAL(RpVec)[i]);
		}
		*cmbdpvalue = 1 - pow(1-*cmbdpvalue, k);
	} else if (!strcmp(method, "max")) {
		*cmbdpvalue = REAL(RpVec)[0];
		for (int i=1; i<k; i++) {
			*cmbdpvalue = fmax2(*cmbdpvalue, REAL(RpVec)[i]);
		}
		*cmbdpvalue = pow(*cmbdpvalue, k);
	} else if (!strcmp(method, "sum")) {
		for (int i=0; i<k; i++) {
			*cmbdpvalue += REAL(RpVec)[i];
		}
		if (k <= 30) {
			*cmbdpvalue = pConvolveUniform(*cmbdpvalue, (double)k);
		} else {
			*cmbdpvalue = pnorm(*cmbdpvalue, (double)k/2.0, sqrt((double)k/12.0), 1, 0);
		}
	} else {
		*cmbdpvalue = 3.1415926;
	}
	// return
	UNPROTECT(1);
	return(Rcmbdpvalue);
}
示例#19
0
SEXP bernoulliprobrandom(SEXP patterns, SEXP outcomex,SEXP lambdacoef, 
	SEXP gh, SEXP momentdata, SEXP probit)
{
	SEXP ans;
	int irow, outcome, index, noutcomes, nrows, ipoint, npoints, level2size, ilambda, lprobit, *rpatterns = INTEGER(patterns);
	double  *routcomex = REAL(outcomex), *rans,
		neww,newp, *rmomentdata=REAL(momentdata),
		*rgh=REAL(gh),*rlambdacoef=REAL(lambdacoef);
	double product, sum, myoutcomex, myoutcomep;
	
	lprobit = asLogical(probit);
	
	noutcomes = LENGTH(outcomex);
	nrows = LENGTH(patterns)/noutcomes;
	npoints = LENGTH(gh)/2;
	level2size=LENGTH(lambdacoef);
	
	PROTECT(ans = allocVector(REALSXP,nrows));
	
	rans = REAL(ans);
	
	
	for (irow=0; irow < nrows; irow++) {
		/* Rprintf("irow  %d\n",irow); */
		sum=0.0;
/* calculate transformed w and p */
		for (ipoint=0; ipoint < npoints; ipoint++) {
			/* Rprintf("momentdata  %f,%f\n",rmomentdata[irow],rmomentdata[nrows+irow]); */
			newp = rmomentdata[irow]+rmomentdata[nrows+irow]*rgh[ipoint];
			neww = log(rmomentdata[nrows+irow])+
				(rgh[ipoint]*rgh[ipoint])/2.0+log(rgh[npoints+ipoint])-
				newp*newp/2.0;
			/* Rprintf("newp,neww  %f,%f\n",newp,neww); */
			ilambda=0;
			product=1.0;
			for (outcome=0; outcome <noutcomes; outcome++) {
				/* calculate outcome probability for this outcome */
				myoutcomex = routcomex[outcome]+
					rlambdacoef[ilambda]*newp;
				if (lprobit)
					myoutcomep=pnorm(myoutcomex,0,1,TRUE,FALSE);
				else
					myoutcomep=1.0/(1+exp(-myoutcomex));
				ilambda=(ilambda+1) % level2size;				
				/* update likelihood for this observation */
			/*  Rprintf("myoutcomep  %f\n",myoutcomep); */
				index = irow+outcome*nrows;
				if (rpatterns[index]!=NA_INTEGER) {
				  if (rpatterns[index]==1) product = product*myoutcomep;
				  else product = product*(1-myoutcomep); 
				}
			}
			sum=sum+product*exp(neww);
		}
		rans[irow]=sum;
	}
	UNPROTECT(1);		
	return ans;
}
示例#20
0
文件: pLausen94.c 项目: cran/TWIX
void C_pLausen94_all(const double *Q, double N, const double *m, int N_m, double *pval)
{
	int i,j;
	double *m1 = Calloc(N_m, double);
	double *m2 = Calloc(N_m, double);
	double *T = Calloc(N_m-1, double);
	if(N_m < 2){
		m1[0] = m[0];
		m2[0] = m[0];
		N_m = 1;
	}
	else{
		for(i = 0; i < N_m-1; i++){
			m1[i] = m[i];
			m2[i] = m[i+1];
		}
	}
	/* compute t and D */
	for(j = 0; j < N_m; j++){
		pval[j] = 0.0;
		double D = 0.0;
		for(i = 0; i < N_m-1; i++){
			T[i] = sqrt(1.0-(m1[i]*(N-m2[i]))/((N-m1[i])*m2[i]));
			D += (M_1_PI)*exp(-(pow(Q[j],2))/2)*(T[i] - ((pow(Q[j],2))/4 -1)*(pow(T[i],3))/6);
		}
		pval[j] = 2.0 * (1.0 - pnorm(Q[j], 0.0, 1.0, 1, 0)) + D;
		if(pval[j] > 1.0){
			pval[j] = 1.0;
		}
		if(pval[j] <= FLT_EPSILON){
			pval[j] = 0.0;
		}
		//*pval[j] = 1.0 - pval[j];
	}
	if(N_m - 1 < 1){
		pval[0] = 2.0 * (1.0 - pnorm(Q[0], 0.0, 1.0, 1, 0));
		if(pval[0] > 1.0){
			pval[0] = 1.0;
		}
		if(pval[0] <= FLT_EPSILON){
			pval[0] = 0.0;
		}
		//*pval[0] = 1.0 - pval[0];
	}
	Free(m1);Free(m2);Free(T);
}
示例#21
0
// Gradient of the max-stable Brown-Resnick model:
void Grad_Brow_Resn(double vario, int *flag, double *gradcor, double *grad,
		    int *npar, double *par, double x, double y)
{
  // Initialization variables:
  double a=0.0, a2x=0.0, a2y=0.0, ao2=0.0, ax=0.0, ay=0.0;
  double axy=0.0, ax2=0.0, ay2=0.0, dx=0.0, dy=0.0, C=0.0;
  double d2V=0.0, daV=0.0, dad2V=0.0, dadxV=0.0, dadyV=0.0;
  double dxV=0.0, dyV=0.0, lyx=0.0, omz2=0.0, omw2=0.0;
  double opzw=0.0, px=0.0, py=0.0, x2=0.0, y2=0.0, w=0.0, z=0.0;
  int i=0;
  // defines useful quantities:
  a=sqrt(vario);// Husler-Reiss coefficient (lambda)
  ao2=0.5*a;
  ax=a*x;
  ay=a*y;
  a2x=a*ax;
  a2y=a*ay;
  axy=ax*y;
  x2=pow(x,2);
  y2=pow(y,2);
  ax2=a*x2;
  ay2=a*y2;
  lyx=log(y/x)/a;
  z=ao2+lyx;
  w=ao2-lyx;
  opzw=1+z*w;
  omz2=1-pow(z,2);
  omw2=1-pow(w,2);
  px=pnorm(z,0,1,1,0);
  py=pnorm(w,0,1,1,0);
  dx=dnorm(z,0,1,0);
  dy=dnorm(w,0,1,0);
  dxV=px/x2+dx/ax2-dy/axy;
  dyV=py/y2+dy/ay2-dx/axy;
  d2V=(w*dx*y+z*dy*x)/(ax2*ay2);
  daV=-w*dx/ax-z*dy/ay;
  dadxV=(opzw*dy/y-omw2*dx/x)/a2x;
  dadyV=(opzw*dx/x-omz2*dy/y)/a2y;
  dad2V=(z*omw2-2*w)*dx/(ax2*a2y)+
    (w*omz2-2*z)*dy/(ay2*a2x);
  dad2V=(z-z*w*w-2*w)*dx/ax2/a2y+(w-z*z*w-2*z)*dy/ay2/a2x;
  C=daV+(dad2V+dadxV*dyV+dxV*dadyV)/(d2V+dxV*dyV);
  // Derivatives with respect to the variogram parameters
  for(i=0;i<*npar;i++) grad[i]=0.5*C*gradcor[i]/a;
  return;
}
示例#22
0
文件: util.cpp 项目: mnievesc/eems
/*
  Truncated normal probability density function, on the log scale,
  with support [-bnd,+bnd], including the normalizing constant
*/
double dtrnormln(const double x, const double mu, const double sigma2, const double bnd) {
  double pln = -Inf;
  if ( (sigma2>0) && (x>=-bnd) && (x<=bnd) ) {
    boost::math::normal pnorm(mu,sqrt(sigma2));
    pln = - 0.5 * log(sigma2) - 0.5 * (x-mu) * (x-mu) / sigma2
      - log(cdf(pnorm,bnd) - cdf(pnorm,-bnd));
  }
  return (pln);
}
示例#23
0
文件: gamma.c 项目: amnh/poy5
value gamma_CAML_pnorm( value mu, value sigma, value p )
{
    CAMLparam3( mu, sigma, p );
    CAMLlocal1( r );
    double res;
    res = pnorm( Double_val(p), Double_val(mu), Double_val(sigma), 1, 0);
    r = caml_copy_double( res );
    CAMLreturn( r );
}
示例#24
0
// Cálculo da quantidade do ativo objeto da opção para realizar o delta hedging.
float hedging_bs(float T, float t, float S0, float K, float r, float sigma, optionType opcao) {

	float *d = bs_d(T, t, S0, K, r, sigma);

	switch (opcao)
	{
	case otEuroCall:
		return pnorm(d[0]);
		break;
	case otEuroPut:
		return -pnorm(-d[0]);
		break;
	default:
		return 0.0;
		break;
	}
	free(d);
}
示例#25
0
// Calcula o preço de uma opção
float preco_bs(float T, float t, float S0, float K, float r, float sigma, optionType opcao) {

	float *d = bs_d(T, t, S0, K, r, sigma);

	switch (opcao)
	{
	case otEuroCall:
		return pnorm(d[0]) * S0 - pnorm(d[1]) * K * exp(-r * (T - t));
		break;
	case otEuroPut:
		return pnorm(-d[1]) * K * exp(-r * (T - t)) - pnorm(-d[0]) * S0;
		break;
	default:
		return 0.0;
		break;
	}
	free(d);
}
///////////////////////////////////////////////////////////////////
// DEFINE THE MEASUREMENT DENSITY FOR CALCULATING THE LIKELIHOOD
///////////////////////////////////////////////////////////////////
void null_chickenpox_meas_dens (double *lik, double *y, double *x, double *p, int give_log,
			int *obsindex, int *stateindex, int *parindex, int *covindex,
			int ncovar, double *covar, double t) {
  
  double report_rate, tau;
  double tol = 1.0e-18;
  // PUT PARS ON NATURAL SCALE
  tau = exp(LOGTAU);
  report_rate = expit(LOGITRHO);

  if(CHICKENPOX > 0.0){
   *lik = pnorm(CHICKENPOX+0.5,report_rate*I,tau*I,1,0) - pnorm(CHICKENPOX-0.5,report_rate*I,tau*I,1,0)+ tol;  
  } else{
   *lik = pnorm(CHICKENPOX+0.5,report_rate*I,tau*I,1,0)+ tol;  
  }
  if (give_log) *lik = log(*lik);
  if (!isfinite(*lik)) Rprintf("chickenpox_meas_dens %lg %lg %lg %lg %lg\n",CHICKENPOX,report_rate,tau,I,*lik);
}
示例#27
0
gnm_float
psnorm (gnm_float x, gnm_float shape, gnm_float location, gnm_float scale, gboolean lower_tail, gboolean log_p)
{
    gnm_float result;

    if (shape == 0.)
        return pnorm (x, location, scale, lower_tail, log_p);

    result = pnorm (x, location, scale, TRUE, FALSE) - 2 * gnm_owent ((x - location)/scale, shape);

    if (!lower_tail)
        result = 1. - result;

    if (log_p)
        return gnm_log (result);
    else
        return result;
}
示例#28
0
文件: funs.cpp 项目: cran/mpbart
double rtrun(double mu, double sigma,double trunpt, int above) 
{
	double FA,FB,rnd,result,arg ;
	if (above) {
		FA=0.0; FB=pnorm(((trunpt-mu)/(sigma)),0.0,1.0,1,0);
			}
	else {
		FB=1.0; FA=pnorm(((trunpt-mu)/(sigma)),0.0,1.0,1,0);
		}
	
	GetRNGstate();
	rnd=unif_rand();
	arg=rnd*(FB-FA)+FA;
	if(arg > .999999999) arg=.999999999;
	if(arg < .0000000001) arg=.0000000001;
	result = mu + sigma*qnorm(arg,0.0,1.0,1,0);
	PutRNGstate();
	return result;
}
示例#29
0
文件: use.c 项目: AndrewLJackson/siar
//truncated normal ratio function:
double truncatedrat (double old, double sd, double low, double high, double newvalue)
{
    double lowlimold, upplimold, lowlimnew, upplimnew, plowold, puppold, plownew, puppnew, ratio;
    
    lowlimold = (low - old)/sd;
    upplimold = (high - old)/sd;
    lowlimnew = (low - newvalue)/sd;
    upplimnew = (high - newvalue)/sd;
    //plowold = normal_cdf(lowlimold);
    //puppold = normal_cdf(upplimold);
    //plownew = normal_cdf(lowlimnew);
    //puppnew = normal_cdf(upplimnew);
    plowold = pnorm(lowlimold,0,1,0,0);
    puppold = pnorm(upplimold,0,1,0,0);
    plownew = pnorm(lowlimnew,0,1,0,0);
    puppnew = pnorm(upplimnew,0,1,0,0);
    ratio = (puppold - plowold)/(puppnew - plownew);
    return ratio;        
}
示例#30
0
/* Group sequential boundary crossing probability computation per Jennison & Turnbull
   This version uses all pointer arguments so that it can be called from R or Splus
   xnanal - # of possible analyses in the group-sequential designs
            (interims + final)
	ntheta - # of theta values for which boundary crossing probabilities are to be computed
   theta  - vector of drift parameters
   I      - statistical information available at each analysis
   a      - lower cutoff points for z statistic at each analysis
   b      - upper cutoff points for z statistic at each analysis
   xprobhi- vector to return probability of rejecting (Z>bj) at
            jth interim analysis, j=1...nanal
   xproblo- vector to return probability of rejecting (Z<aj) at
            jth interim analysis, j=1...nanal
   xr     - determinant of # of grid points for numerical integration
            r=17 will give a max of 201 points which is what they recommend
*/
void probrej(int *xnanal,int *ntheta,double *xtheta,double *I,double *a,double *b,
             double *xproblo,double *xprobhi,int *xr)
{   int r,i,m1,m2,nanal,k;
    double theta;
    double *problo,*probhi;
    double probneg(double,int,double,double *,double *,double,double);
    double probpos(double,int,double,double *,double *,double,double);
/* note: should allocat zwk & wwk dynamically...*/
    double mu,zwk[1000],wwk[1000],hwk[1000],zwk2[1000],wwk2[1000],hwk2[1000],
           *z1,*z2,*w1,*w2,*h,*h2,*tem;
    void h1(double,int,double *,double,double *, double *);
    void hupdate(double,double *,int,double,double *, double *,
                                 int,double,double *, double *);
    int gridpts(int, double,double,double,double *, double *);
    r=xr[0]; nanal=xnanal[0]; 
    for(k=0;k<ntheta[0];k++)
    {  theta=xtheta[k];
       problo=xproblo+k*nanal;
       probhi=xprobhi+k*nanal;
/* compute probability of rejecting at 1st interim analysis */
       if (nanal < 1) return;
       mu=theta*sqrt(I[0]);
       problo[0]=pnorm(mu-a[0],0.,1.,0,0);
       probhi[0]=pnorm(b[0]-mu,0.,1.,0,0);
/* compute h1 */
       z1=zwk; w1=wwk; h=hwk;
       m1=gridpts(r,mu,a[0],b[0],z1,w1);
       h1(theta,m1,w1,I[0],z1,h);
       z2=zwk2; w2=wwk2; h2=hwk2;
/* update h and compute rejection probabilities at each interim */
       for(i=1;i<nanal;i++)
       {   probhi[i]=probpos(theta,m1,b[i],z1,h,I[i-1],I[i]);
           problo[i]=probneg(theta,m1,a[i],z1,h,I[i-1],I[i]);
           if (i<nanal-1)
	   {   mu=theta*sqrt(I[i]);
	       m2=gridpts(r,mu,a[i],b[i],z2,w2);
               hupdate(theta,w2,m1,I[i-1],z1,h,m2,I[i],z2,h2);
               m1=m2;
               tem=z1; z1=z2; z2=tem;
               tem=w1; w1=w2; w2=tem;
               tem=h;  h=h2;  h2=tem;
}   }   }  }