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;
}
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;
}
//----------------------------------------------------------------------
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);
}
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);
}
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;
}
/* 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);
}
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;
}
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);
}
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);
}
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;
}
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;
}
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;
}
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);
}
// 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;
}
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;
}
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;
}
// 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;
}
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);
}
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;
}
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);
}
// 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;
}
/*
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);
}
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 );
}
// 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);
}
// 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);
}
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;
}
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;
}
//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;
}
/* 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;
} } } }
