int K_small(double q, double v, double a, double w, double epsilon)
{
if(v == 0) return ceil(fmax(0.0, w/2 - sqrt(q)/2/a * qnorm(fmax(0.0, fmin(1.0, epsilon/(2-2*w))),0,1,1,0)));
if(v > 0) return(K_small(q, -v, a, w, exp(-2*a*w*v)*epsilon));
double S2 = w - 1 + 0.5/v/a * log(epsilon/2 * (1-exp(2*v*a)));
double S3 = (0.535 * sqrt(2*q) + v*q + a*w)/2/a;
double S4 = w/2 - sqrt(q)/2/a * qnorm(fmax(0.0, fmin(1.0, epsilon * a / 0.3 / sqrt(2*M_PI*q) * exp(v*v*q/2 + v*a*w))),0,1,1,0);
return ceil(fmax(fmax(fmax(S2, S3), S4), 0.0));
}
double invqnorm(double x) {
// Initial approximation is linear. Starting with y0 = 0.0 works just as well.
double y0 = x - 0.5;
if (x <= 0.0)
return 0.0;
if (x >= 1.0)
return 0.0;
double y = y0;
int niter = 0;
while (1) {
double backx = qnorm(y);
double err = fabs(x - backx);
if (err < INVQNORM_TOL)
break;
if (niter > INVQNORM_MAXITER) {
fprintf(stderr, "%s: internal coding error: max iterations %d exceeded in invqnorm.\n",
MLR_GLOBALS.bargv0, INVQNORM_MAXITER);
exit(1);
}
double m = sqrt(2*M_PI) * exp(y*y/2.0);
double delta_y = m * (x - backx);
y += delta_y;
niter++;
}
return y;
}
gnm_float
qsnorm (gnm_float p, gnm_float shape, gnm_float location, gnm_float scale,
gboolean lower_tail, gboolean log_p)
{
gnm_float x0;
gnm_float params[3];
if (gnm_isnan (p) || gnm_isnan (shape) || gnm_isnan (location) || gnm_isnan (scale))
return gnm_nan;
if (shape == 0.)
return qnorm (p, location, scale, lower_tail, log_p);
if (!log_p && p > 0.9) {
/* We're far into the tail. Flip. */
p = 1 - p;
lower_tail = !lower_tail;
}
x0 = 0.0;
params[0] = shape;
params[1] = location;
params[2] = scale;
return pfuncinverter (p, params, lower_tail, log_p,
gnm_ninf, gnm_pinf, x0,
psnorm1, dsnorm1);
}
double F77_SUB(fqnorm)(double *p, double *mean, double *sd, int *lowertail, int *logp ) {
/* Debug purpose
printf("p = %e, mean = %e, sd = %d\n",*p,*mean,*sd);
printf("lowertail = %d, log.p = %d\n",*lowertail, *logp);
double res = qnorm(*p, *mean, *sd, *lowertail, *logp);
printf("res = %e\n",res);
*/
return(qnorm(*p, *mean, *sd, *lowertail, *logp));
}
double qpois(double p, double lambda, int lower_tail, int log_p)
{
double mu, sigma, gamma, z, y;
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(lambda))
return p + lambda;
#endif
if(!R_FINITE(lambda))
ML_ERR_return_NAN;
if(lambda < 0) ML_ERR_return_NAN;
R_Q_P01_check(p);
if(lambda == 0) return 0;
if(p == R_DT_0) return 0;
if(p == R_DT_1) return ML_POSINF;
mu = lambda;
sigma = sqrt(lambda);
/* gamma = sigma; PR#8058 should be kurtosis which is mu^-0.5 */
gamma = 1.0/sigma;
/* Note : "same" code in qpois.c, qbinom.c, qnbinom.c --
* FIXME: This is far from optimal [cancellation for p ~= 1, etc]: */
if(!lower_tail || log_p) {
p = R_DT_qIv(p); /* need check again (cancellation!): */
if (p == 0.) return 0;
if (p == 1.) return ML_POSINF;
}
/* temporary hack --- FIXME --- */
if (p + 1.01*DBL_EPSILON >= 1.) return ML_POSINF;
/* y := approx.value (Cornish-Fisher expansion) : */
z = qnorm(p, 0., 1., /*lower_tail*/TRUE, /*log_p*/FALSE);
#ifdef HAVE_NEARBYINT
y = nearbyint(mu + sigma * (z + gamma * (z*z - 1) / 6));
#else
y = round(mu + sigma * (z + gamma * (z*z - 1) / 6));
#endif
z = ppois(y, lambda, /*lower_tail*/TRUE, /*log_p*/FALSE);
/* fuzz to ensure left continuity; 1 - 1e-7 may lose too much : */
p *= 1 - 64*DBL_EPSILON;
/* If the mean is not too large a simple search is OK */
if(lambda < 1e5) return do_search(y, &z, p, lambda, 1);
/* Otherwise be a bit cleverer in the search */
{
double incr = floor(y * 0.001), oldincr;
do {
oldincr = incr;
y = do_search(y, &z, p, lambda, incr);
incr = fmax2(1, floor(incr/100));
} while(oldincr > 1 && incr > lambda*1e-15);
return y;
}
}
double qlnorm(double p, double meanlog, double sdlog, int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(meanlog) || ISNAN(sdlog))
return p + meanlog + sdlog;
#endif
R_Q_P01_boundaries(p, 0, ML_POSINF);
return exp(qnorm(p, meanlog, sdlog, lower_tail, log_p));
}
gnm_float
qsnorm (gnm_float p, gnm_float shape, gnm_float location, gnm_float scale, gboolean lower_tail, gboolean log_p)
{
if (shape == 0.)
return qnorm (p, location, scale, lower_tail, log_p);
else if (log_p)
return 0.;
else
return 0;
}
/* 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);
}
Type qSHASHo(Type p, Type mu, Type sigma, Type nu, Type tau, int log_p = 0)
{
// TODO : Replace log(x+sqrt(x^2+1)) by a better approximation for asinh(x).
if(!log_p) return mu + sigma*sinh((1/tau)* log(qnorm(p)+sqrt(qnorm(p)*qnorm(p)+1)) + (nu/tau));
else return mu + sigma*sinh((1/tau)*log(qnorm(exp(p))+sqrt(qnorm(exp(p))*qnorm(exp(p))+1))+(nu/tau));
}
double qnbinom(double p, double size, double prob, int lower_tail, int log_p)
{
double P, Q, mu, sigma, gamma, z, y;
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(size) || ISNAN(prob))
return p + size + prob;
#endif
if (prob <= 0 || prob > 1 || size <= 0) ML_ERR_return_NAN;
/* FIXME: size = 0 is well defined ! */
if (prob == 1) return 0;
R_Q_P01_boundaries(p, 0, ML_POSINF);
Q = 1.0 / prob;
P = (1.0 - prob) * Q;
mu = size * P;
sigma = sqrt(size * P * Q);
gamma = (Q + P)/sigma;
/* Note : "same" code in qpois.c, qbinom.c, qnbinom.c --
* FIXME: This is far from optimal [cancellation for p ~= 1, etc]: */
if(!lower_tail || log_p) {
p = R_DT_qIv(p); /* need check again (cancellation!): */
if (p == R_DT_0) return 0;
if (p == R_DT_1) return ML_POSINF;
}
/* temporary hack --- FIXME --- */
if (p + 1.01*DBL_EPSILON >= 1.) return ML_POSINF;
/* y := approx.value (Cornish-Fisher expansion) : */
z = qnorm(p, 0., 1., /*lower_tail*/TRUE, /*log_p*/FALSE);
y = floor(mu + sigma * (z + gamma * (z*z - 1) / 6) + 0.5);
z = pnbinom(y, size, prob, /*lower_tail*/TRUE, /*log_p*/FALSE);
/* fuzz to ensure left continuity: */
p *= 1 - 64*DBL_EPSILON;
/* If the C-F value is not too large a simple search is OK */
if(y < 1e5) return do_search(y, &z, p, size, prob, 1);
/* Otherwise be a bit cleverer in the search */
{
double incr = floor(y * 0.001), oldincr;
do {
oldincr = incr;
y = do_search(y, &z, p, size, prob, incr);
incr = fmax2(1, floor(incr/100));
} while(oldincr > 1 && incr > y*1e-15);
return y;
}
}
real_t qdistribution(const real_t px, const Distribution dist, const bool tail, const bool logp){
if(NULL==dist){ return NAN; }
switch(dist->key){
case 0: return 0;
case 'W': return qweibull(px,dist->param[0],dist->param[1],tail,logp);
case 'L': return qlogistic(px,dist->param[0],dist->param[1],tail,logp);
case 'N': return qnorm(px,dist->param[0],dist->param[1],tail,logp);
case 'M': return qmixnorm(px,(NormMixParam)dist->info,tail,logp);
default: errx(EXIT_FAILURE,"Unrecognised distribution in %s",__func__);
}
// Never reach here
return NAN;
}
void cis_data::normalTransform(vector < float > & V) {
vector < float > R;
myranker::rank(V, R);
double max = 0;
for (int s = 0 ; s < sample_count ; s ++) {
R[s] = R[s] - 0.5;
if (R[s] > max) max = R[s];
}
max = max + 0.5;
for (int s = 0 ; s < sample_count ; s ++) {
R[s] /= max;
V[s] = qnorm(R[s], 0.0, 1.0, 1, 0);
}
}
int
main(int argc, char** argv)
{
/* something to force the library to be included */
qnorm(0.7, 0.0, 1.0, 0, 0);
printf("*** loaded '%s'\n", argv[0]);
set_seed(123, 456);
N01_kind = AHRENS_DIETER;
printf("one normal %f\n", norm_rand());
set_seed(123, 456);
N01_kind = BOX_MULLER;
printf("normal via BM %f\n", norm_rand());
return 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);
}
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;
}
// ****** update_Data_GS_doubly ***********************
// *** Update of the event-time in the case of doubly censored data
//
// Yevent[nP x gg->dim()] ........ on INPUT: current vector of (imputed) log(event times)
// on OUTPUT: updated vector of (augmented) log(event times)
// i.e. augmented log(T2 - T1), where T1 = onset time, T2 = event time (on a study scale)
// regresResM[nP x gg->dim()] .... on INPUT: current vector of regression residuals (y - x'beta - z'b))
// on OUTPUT: updated vector of regression residuals
// Yonset[nP x gg->dim()] .... log-onset times
// i.e. log(T1)
// t_left[nP x gg->dim()] ....
// t_right[nP x gg->dim()].... observed event times (on a study scale)
// status[nP x gg->dim()] .... censoring status for event
// rM[nP] .................... component labels taking values 0, 1, ..., gg->total_length()-1
// gg ........................ G-spline defining the distribution of the log-time-to-event (log(T2 - T1))
// nP ........................ number of observational vectors
// n_censored ................ number of censored event times
//
void
update_Data_GS_doubly(double* Yevent,
double* regresResM,
const double* Yonset,
const double* t_left,
const double* t_right,
const int* status,
const int* rM,
const Gspline* gg,
const int* nP)
{
int obs, j;
double t_onset, yL, yU, help;
double mu_jk = 0;
double PhiL = 0;
double PhiU = 0;
double u = 0;
double PhiInv = 0;
double stres = 0;
double invsigma[_max_dim];
double invscale[_max_dim];
for (j = 0; j < gg->dim(); j++){
invsigma[j] = 1/gg->sigma(j);
invscale[j] = 1/gg->scale(j);
}
double* y_event = Yevent;
double* regRes = regresResM;
const double* y_onset = Yonset;
const double* t1 = t_left;
const double* t2 = t_right;
const int* stat = status;
const int* rp = rM;
for (obs = 0; obs < *nP; obs++){
for (j = 0; j < gg->dim(); j++){
t_onset = (*y_onset > -_emax ? exp(*y_onset) : 0.0);
if (!R_finite(t_onset)) throw returnR("Trap: t_onset equal to NaN in 'update_Data_GS_doubly'", 1);
*regRes -= *y_event;
switch (*stat){
case 1: /* exactly observed, but the onset time might not be observed exactly */
help = (*t1) - t_onset;
if (help <= _ZERO_TIME_) *y_event = _LOG_ZERO_TIME_;
else *y_event = log(help);
break;
case 0: /* right censored */
mu_jk = gg->mu_component(j, *rp);
help = (*t1) - t_onset;
if (help <= _ZERO_TIME_){ // time-to-event right censored at 0, generate an exact time from N(mean, variance)
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
yL = log(help);
stres = (yL + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiL = pnorm(stres, 0, 1, 1, 0);
if (PhiL >= 1 - NORM_ZERO){ // censored time irrealistic large (out of the prob. scale)
*y_event = yL;
}
else{
if (PhiL <= NORM_ZERO){ // censoring time equal to "zero", generate an exact time from N(mean, variance),
// i.e. from the full not-truncated distribution
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
u = runif(0, 1) * (1 - PhiL) + PhiL;
PhiInv = qnorm(u, 0, 1, 1, 0);
if (PhiInv == R_PosInf){ // u was equal to 1, additional check added 16/12/2004
*y_event = yL;
}
else{
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
}
}
}
break;
case 2: /* left censored event => onset had to be left censored as well at the same time */
mu_jk = gg->mu_component(j, *rp);
help = (*t1) - t_onset;
if (help <= _ZERO_TIME_) *y_event = _LOG_ZERO_TIME_; // time-to-event left censored at 0 => time-to-event = 0
else{
yL = log(help);
stres = (yL + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiU = pnorm(stres, 0, 1, 1, 0);
if (PhiU <= NORM_ZERO){ // left censoring time irrealistic low (equal to "zero")
*y_event = _LOG_ZERO_TIME_;
}
else{
if (PhiU >= 1 - NORM_ZERO){ // left censoring time equal to "infty", generate an exact time from N(mean, variance),
// i.e. from the full not-truncated distribution
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
u = runif(0, 1) * PhiU;
PhiInv = qnorm(u, 0, 1, 1, 0);
if (PhiInv == R_NegInf){ // u was equal to 0, additional check added 16/12/2004
*y_event = yL;
}
else{
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
}
}
}
break;
case 3: /* interval censored */
mu_jk = gg->mu_component(j, *rp);
help = (*t1) - t_onset;
if (help <= _ZERO_TIME_){ // time-to-event will be left censored
help = (*t2) - t_onset;
if (help <= _ZERO_TIME_){ // too narrow interval located close to zero
*y_event = _LOG_ZERO_TIME_;
}
else{ // code for left censored observations
yL = log(help);
stres = (yL + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiU = pnorm(stres, 0, 1, 1, 0);
if (PhiU <= NORM_ZERO){ // left censoring time irrealistic low (equal to "zero")
*y_event = _LOG_ZERO_TIME_;
}
else{
if (PhiU >= 1 - NORM_ZERO){ // left censoring time equal to "infty", generate an exact time from N(mean, variance),
// i.e. from the full not-truncated distribution
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
u = runif(0, 1) * PhiU;
PhiInv = qnorm(u, 0, 1, 1, 0);
if (PhiInv == R_NegInf){ // u was equal to 0, additional check added 16/12/2004
*y_event = yL;
}
else{
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
}
}
}
}
else{
yL = log(help);
help = (*t2) - t_onset;
if (help <= _ZERO_TIME_){ // too narrow interval located close to zero
*y_event = _LOG_ZERO_TIME_;
}
else{
yU = log(help);
stres = (yL + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiL = pnorm(stres, 0, 1, 1, 0);
stres = (yU + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiU = pnorm(stres, 0, 1, 1, 0);
PhiInv = PhiU - PhiL;
if (PhiInv <= NORM_ZERO){ // too narrow interval, or the interval out of the probability scale
// (both limits in "zero" probability region)
// generate something inbetween
u = runif(0, 1);
*y_event = yL + u*(yU - yL);
}
else{
if (PhiInv >= 1 - NORM_ZERO){ // too large interval, practically (-infty, +infty), generate an exact time from N(mean, variance)
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
u = runif(0, 1) * PhiInv + PhiL;
PhiInv = qnorm(u, 0, 1, 1, 0);
if (!R_finite(PhiInv)){ // u was either zero or one, additional check added 16/12/2004
u = runif(0, 1);
*y_event = yL + u*(yU - yL);
}
else{
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
}
}
}
}
break;
} /** end of switch (status) **/
*regRes += (*y_event);
/*** This section just performs additional checks to prevent simulations with NaN's ***/
if (!R_finite(*y_event) || !R_finite(*regRes)){
int condit;
REprintf("\nY[%d,%d]=%e, regRes[%d,%d]=%e, r[%d,%d]=%d, status[%d,%d]=%d, stres=%e",
obs, j, *y_event, obs, j, *regRes, obs, j, *rp, obs, j, *stat, stres);
REprintf("; mean=%e", mu_jk);
REprintf("; invvar=%e", gg->invsigma2(j));
REprintf("\nu=%3.20e, PhiL=%3.20e, PhiU=%3.20e, PhiInv=%3.20e", u, PhiL, PhiU, PhiInv);
REprintf("NORM_ZERO=%3.20e, 1-NORM_ZERO=%3.20e", NORM_ZERO, 1-NORM_ZERO);
switch (*stat){
case 0:
condit = 1*(PhiL >= 1 - NORM_ZERO);
REprintf("\nPhiL >= 1 - NORM_ZERO: %d", condit);
condit = 1*(PhiL <= NORM_ZERO);
REprintf("\nPhiL <= NORM_ZERO: %d", condit);
break;
case 2:
condit = 1*(PhiU >= 1 - NORM_ZERO);
REprintf("\nPhiU >= 1 - NORM_ZERO: %d", condit);
condit = 1*(PhiU <= NORM_ZERO);
REprintf("\nPhiU <= NORM_ZERO: %d", condit);
break;
case 3:
condit = 1*(PhiU-PhiL >= 1 - NORM_ZERO);
REprintf("\nPhiU-PhiL >= 1 - NORM_ZERO: %d", condit);
condit = 1*(PhiU-PhiL <= NORM_ZERO);
REprintf("\nPhiU-PhiL <= NORM_ZERO: %d", condit);
break;
}
REprintf("\n");
throw returnR("Trap in update_Data_GS_doubly: NaN generated.", 1);
}
y_event++;
regRes++;
y_onset++;
t1++;
t2++;
stat++;
}
rp++;
}
return;
} /*** end of function update_Data_GS_doubly ***/
// MM_R attribute_hidden
double qchisq_appr(double p, double nu, double g /* = log Gamma(nu/2) */,
logical lower_tail, logical log_p, double tol /* EPS1 */)
{
#define C7 4.67
#define C8 6.66
#define C9 6.73
#define C10 13.32
double alpha, a, c, ch, p1;
double p2, q, t, x;
/* test arguments and initialise */
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(nu))
return p + nu;
#endif
R_Q_P01_check(p);
if (nu <= 0) ML_ERR_return_NAN;
alpha = 0.5 * nu;/* = [pq]gamma() shape */
c = alpha-1;
if(nu < (-1.24)*(p1 = R_DT_log(p))) { /* for small chi-squared */
/* log(alpha) + g = log(alpha) + log(gamma(alpha)) =
* = log(alpha*gamma(alpha)) = lgamma(alpha+1) suffers from
* catastrophic cancellation when alpha << 1
*/
double lgam1pa = (alpha < 0.5) ? lgamma1p(alpha) : (log(alpha) + g);
ch = exp((lgam1pa + p1)/alpha + M_LN2);
#ifdef DEBUG_qgamma
REprintf(" small chi-sq., ch0 = %g\n", ch);
#endif
} else if(nu > 0.32) { /* using Wilson and Hilferty estimate */
x = qnorm(p, 0, 1, lower_tail, log_p);
p1 = 2./(9*nu);
ch = nu*pow(x*sqrt(p1) + 1-p1, 3);
#ifdef DEBUG_qgamma
REprintf(" nu > .32: Wilson-Hilferty; x = %7g\n", x);
#endif
/* approximation for p tending to 1: */
if( ch > 2.2*nu + 6 )
ch = -2*(R_DT_Clog(p) - c*log(0.5*ch) + g);
} else { /* "small nu" : 1.24*(-log(p)) <= nu <= 0.32 */
ch = 0.4;
a = R_DT_Clog(p) + g + c*M_LN2;
#ifdef DEBUG_qgamma
REprintf(" nu <= .32: a = %7g\n", a);
#endif
do {
q = ch;
p1 = 1. / (1+ch*(C7+ch));
p2 = ch*(C9+ch*(C8+ch));
t = -0.5 +(C7+2*ch)*p1 - (C9+ch*(C10+3*ch))/p2;
ch -= (1- exp(a+0.5*ch)*p2*p1)/t;
} while(fabs(q - ch) > tol * fabs(ch));
}
return ch;
}
double qbinom(double p, double n, double pr, int lower_tail, int log_p)
{
double q, mu, sigma, gamma, z, y;
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(n) || ISNAN(pr))
return p + n + pr;
#endif
if(!R_FINITE(p) || !R_FINITE(n) || !R_FINITE(pr))
ML_ERR_return_NAN;
R_Q_P01_check(p);
if(n != floor(n + 0.5)) ML_ERR_return_NAN;
if (pr < 0 || pr > 1 || n < 0)
ML_ERR_return_NAN;
if (pr == 0. || n == 0) return 0.;
if (p == R_DT_0) return 0.;
if (p == R_DT_1) return n;
q = 1 - pr;
if(q == 0.) return n; /* covers the full range of the distribution */
mu = n * pr;
sigma = sqrt(n * pr * q);
gamma = (q - pr) / sigma;
#ifdef DEBUG_qbinom
REprintf("qbinom(p=%7g, n=%g, pr=%7g, l.t.=%d, log=%d): sigm=%g, gam=%g\n",
p,n,pr, lower_tail, log_p, sigma, gamma);
#endif
/* Note : "same" code in qpois.c, qbinom.c, qnbinom.c --
* FIXME: This is far from optimal [cancellation for p ~= 1, etc]: */
if(!lower_tail || log_p) {
p = R_DT_qIv(p); /* need check again (cancellation!): */
if (p == 0.) return 0.;
if (p == 1.) return n;
}
/* temporary hack --- FIXME --- */
if (p + 1.01*DBL_EPSILON >= 1.) return n;
/* y := approx.value (Cornish-Fisher expansion) : */
z = qnorm(p, 0., 1., /*lower_tail*/TRUE, /*log_p*/FALSE);
y = floor(mu + sigma * (z + gamma * (z*z - 1) / 6) + 0.5);
if(y > n) /* way off */ y = n;
#ifdef DEBUG_qbinom
REprintf(" new (p,1-p)=(%7g,%7g), z=qnorm(..)=%7g, y=%5g\n", p, 1-p, z, y);
#endif
z = pbinom(y, n, pr, /*lower_tail*/TRUE, /*log_p*/FALSE);
/* fuzz to ensure left continuity: */
p *= 1 - 64*DBL_EPSILON;
/*-- Fixme, here y can be way off --
should use interval search instead of primitive stepping down or up */
#ifdef maybe_future
if((lower_tail && z >= p) || (!lower_tail && z <= p)) {
#else
if(z >= p) {
#endif
/* search to the left */
#ifdef DEBUG_qbinom
REprintf("\tnew z=%7g >= p = %7g --> search to left (y--) ..\n", z,p);
#endif
for(;;) {
if(y == 0 ||
(z = pbinom(y - 1, n, pr, /*l._t.*/TRUE, /*log_p*/FALSE)) < p)
return y;
y = y - 1;
}
}
else { /* search to the right */
#ifdef DEBUG_qbinom
REprintf("\tnew z=%7g < p = %7g --> search to right (y++) ..\n", z,p);
#endif
for(;;) {
y = y + 1;
if(y == n ||
(z = pbinom(y, n, pr, /*l._t.*/TRUE, /*log_p*/FALSE)) >= p)
return y;
}
}
}
double qgamma(double p, double alpha, double scale, int lower_tail, int log_p)
/* shape = alpha */
{
#define C7 4.67
#define C8 6.66
#define C9 6.73
#define C10 13.32
#define EPS1 1e-2
#define EPS2 5e-7/* final precision */
#define MAXIT 1000/* was 20 */
#define pMIN 1e-100 /* was 0.000002 = 2e-6 */
#define pMAX (1-1e-12)/* was 0.999998 = 1 - 2e-6 */
const double
i420 = 1./ 420.,
i2520 = 1./ 2520.,
i5040 = 1./ 5040;
double p_, a, b, c, ch, g, p1, v;
double p2, q, s1, s2, s3, s4, s5, s6, t, x;
int i;
/* test arguments and initialise */
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(alpha) || ISNAN(scale))
return p + alpha + scale;
#endif
R_Q_P01_check(p);
if (alpha <= 0) ML_ERR_return_NAN;
/* FIXME: This (cutoff to {0, +Inf}) is far from optimal when log_p: */
p_ = R_DT_qIv(p);/* lower_tail prob (in any case) */
if (/* 0 <= */ p_ < pMIN) return 0;
if (/* 1 >= */ p_ > pMAX) return BOOM::infinity();
v = 2*alpha;
c = alpha-1;
g = lgammafn(alpha);/* log Gamma(v/2) */
/*----- Phase I : Starting Approximation */
#ifdef DEBUG_qgamma
REprintf("qgamma(p=%7g, alpha=%7g, scale=%7g, l.t.=%2d, log_p=%2d): ",
p,alpha,scale, lower_tail, log_p);
#endif
if(v < (-1.24)*R_DT_log(p)) { /* for small chi-squared */
#ifdef DEBUG_qgamma
REprintf(" small chi-sq.\n");
#endif
/* FIXME: Improve this "if (log_p)" :
* (A*exp(b)) ^ 1/al */
ch = pow(p_* alpha*exp(g+alpha*M_LN2), 1/alpha);
if(ch < EPS2) {/* Corrected according to AS 91; MM, May 25, 1999 */
goto END;
}
} else if(v > 0.32) { /* using Wilson and Hilferty estimate */
x = qnorm(p, 0, 1, lower_tail, log_p);
p1 = 0.222222/v;
ch = v*pow(x*sqrt(p1)+1-p1, 3);
#ifdef DEBUG_qgamma
REprintf(" v > .32: Wilson-Hilferty; x = %7g\n", x);
#endif
/* starting approximation for p tending to 1 */
if( ch > 2.2*v + 6 )
ch = -2*(R_DT_Clog(p) - c*log(0.5*ch) + g);
} else { /* for v <= 0.32 */
ch = 0.4;
a = R_DT_Clog(p) + g + c*M_LN2;
#ifdef DEBUG_qgamma
REprintf(" v <= .32: a = %7g\n", a);
#endif
do {
q = ch;
p1 = 1. / (1+ch*(C7+ch));
p2 = ch*(C9+ch*(C8+ch));
t = -0.5 +(C7+2*ch)*p1 - (C9+ch*(C10+3*ch))/p2;
ch -= (1- exp(a+0.5*ch)*p2*p1)/t;
} while(fabs(q - ch) > EPS1*fabs(ch));
}
#ifdef DEBUG_qgamma
REprintf("\t==> ch = %10g:", ch);
#endif
/*----- Phase II: Iteration
* Call pgamma() [AS 239] and calculate seven term taylor series
*/
for( i=1 ; i <= MAXIT ; i++ ) {
q = ch;
p1 = 0.5*ch;
p2 = p_ - pgamma(p1, alpha, 1, /*lower_tail*/true, /*log_p*/false);
#ifdef IEEE_754
if(!R_FINITE(p2))
#else
if(errno != 0)
#endif
return numeric_limits<double>::quiet_NaN();
t = p2*exp(alpha*M_LN2+g+p1-c*log(ch));
b = t/ch;
a = 0.5*t - b*c;
s1 = (210+a*(140+a*(105+a*(84+a*(70+60*a))))) * i420;
s2 = (420+a*(735+a*(966+a*(1141+1278*a)))) * i2520;
s3 = (210+a*(462+a*(707+932*a))) * i2520;
s4 = (252+a*(672+1182*a)+c*(294+a*(889+1740*a))) * i5040;
s5 = (84+2264*a+c*(1175+606*a)) * i2520;
s6 = (120+c*(346+127*c)) * i5040;
ch += t*(1+0.5*t*s1-b*c*(s1-b*(s2-b*(s3-b*(s4-b*(s5-b*s6))))));
if(fabs(q - ch) < EPS2*ch)
goto END;
}
ML_ERROR(ME_PRECISION);/* no convergence in MAXIT iterations */
END:
return 0.5*scale*ch;
}
double qt(double p, double ndf, int lower_tail, int log_p)
{
const static double eps = 1.e-12;
double P, q;
Rboolean neg;
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(ndf))
return p + ndf;
#endif
R_Q_P01_boundaries(p, ML_NEGINF, ML_POSINF);
if (ndf <= 0) ML_ERR_return_NAN;
if (ndf < 1) { /* based on qnt */
const static double accu = 1e-13;
const static double Eps = 1e-11; /* must be > accu */
double ux, lx, nx, pp;
int iter = 0;
p = R_DT_qIv(p);
/* Invert pt(.) :
* 1. finding an upper and lower bound */
if(p > 1 - DBL_EPSILON) return ML_POSINF;
pp = fmin2(1 - DBL_EPSILON, p * (1 + Eps));
for(ux = 1.; ux < DBL_MAX && pt(ux, ndf, TRUE, FALSE) < pp; ux *= 2);
pp = p * (1 - Eps);
for(lx =-1.; lx > -DBL_MAX && pt(lx, ndf, TRUE, FALSE) > pp; lx *= 2);
/* 2. interval (lx,ux) halving
regula falsi failed on qt(0.1, 0.1)
*/
do {
nx = 0.5 * (lx + ux);
if (pt(nx, ndf, TRUE, FALSE) > p) ux = nx; else lx = nx;
} while ((ux - lx) / fabs(nx) > accu && ++iter < 1000);
if(iter >= 1000) ML_ERROR(ME_PRECISION, "qt");
return 0.5 * (lx + ux);
}
/* Old comment:
* FIXME: "This test should depend on ndf AND p !!
* ----- and in fact should be replaced by
* something like Abramowitz & Stegun 26.7.5 (p.949)"
*
* That would say that if the qnorm value is x then
* the result is about x + (x^3+x)/4df + (5x^5+16x^3+3x)/96df^2
* The differences are tiny even if x ~ 1e5, and qnorm is not
* that accurate in the extreme tails.
*/
if (ndf > 1e20) return qnorm(p, 0., 1., lower_tail, log_p);
P = R_D_qIv(p); /* if exp(p) underflows, we fix below */
neg = (!lower_tail || P < 0.5) && (lower_tail || P > 0.5);
if(neg)
P = 2 * (log_p ? (lower_tail ? P : -expm1(p)) : R_D_Lval(p));
else
P = 2 * (log_p ? (lower_tail ? -expm1(p) : P) : R_D_Cval(p));
/* 0 <= P <= 1 ; P = 2*min(P', 1 - P') in all cases */
/* Use this if(log_p) only : */
#define P_is_exp_2p (lower_tail == neg) /* both TRUE or FALSE == !xor */
if (fabs(ndf - 2) < eps) { /* df ~= 2 */
if(P > DBL_MIN) {
if(3* P < DBL_EPSILON) /* P ~= 0 */
q = 1 / sqrt(P);
else if (P > 0.9) /* P ~= 1 */
q = (1 - P) * sqrt(2 /(P * (2 - P)));
else /* eps/3 <= P <= 0.9 */
q = sqrt(2 / (P * (2 - P)) - 2);
}
else { /* P << 1, q = 1/sqrt(P) = ... */
if(log_p)
q = P_is_exp_2p ? exp(- p/2) / M_SQRT2 : 1/sqrt(-expm1(p));
else
q = ML_POSINF;
}
}
else if (ndf < 1 + eps) { /* df ~= 1 (df < 1 excluded above): Cauchy */
if(P > 0)
q = 1/tan(P * M_PI_2);/* == - tan((P+1) * M_PI_2) -- suffers for P ~= 0 */
else { /* P = 0, but maybe = 2*exp(p) ! */
if(log_p) /* 1/tan(e) ~ 1/e */
q = P_is_exp_2p ? M_1_PI * exp(-p) : -1./(M_PI * expm1(p));
else
q = ML_POSINF;
}
}
else { /*-- usual case; including, e.g., df = 1.1 */
double x = 0., y, log_P2 = 0./* -Wall */,
a = 1 / (ndf - 0.5),
b = 48 / (a * a),
c = ((20700 * a / b - 98) * a - 16) * a + 96.36,
d = ((94.5 / (b + c) - 3) / b + 1) * sqrt(a * M_PI_2) * ndf;
Rboolean P_ok1 = P > DBL_MIN || !log_p, P_ok = P_ok1;
if(P_ok1) {
y = pow(d * P, 2 / ndf);
P_ok = (y >= DBL_EPSILON);
}
if(!P_ok) { /* log_p && P very small */
log_P2 = P_is_exp_2p ? p : R_Log1_Exp(p); /* == log(P / 2) */
x = (log(d) + M_LN2 + log_P2) / ndf;
y = exp(2 * x);
}
if ((ndf < 2.1 && P > 0.5) || y > 0.05 + a) { /* P > P0(df) */
/* Asymptotic inverse expansion about normal */
if(P_ok)
x = qnorm(0.5 * P, 0., 1., /*lower_tail*/TRUE, /*log_p*/FALSE);
else /* log_p && P underflowed */
x = qnorm(log_P2, 0., 1., lower_tail, /*log_p*/ TRUE);
y = x * x;
if (ndf < 5)
c += 0.3 * (ndf - 4.5) * (x + 0.6);
c = (((0.05 * d * x - 5) * x - 7) * x - 2) * x + b + c;
y = (((((0.4 * y + 6.3) * y + 36) * y + 94.5) / c
- y - 3) / b + 1) * x;
y = expm1(a * y * y);
q = sqrt(ndf * y);
} else { /* re-use 'y' from above */
if(!P_ok && x < - M_LN2 * DBL_MANT_DIG) {/* 0.5* log(DBL_EPSILON) */
/* y above might have underflown */
q = sqrt(ndf) * exp(-x);
}
else {
y = ((1 / (((ndf + 6) / (ndf * y) - 0.089 * d - 0.822)
* (ndf + 2) * 3) + 0.5 / (ndf + 4))
* y - 1) * (ndf + 1) / (ndf + 2) + 1 / y;
q = sqrt(ndf * y);
}
}
/* Now apply 2-term Taylor expansion improvement (1-term = Newton):
* as by Hill (1981) [ref.above] */
/* FIXME: This can be far from optimal when log_p = TRUE
* but is still needed, e.g. for qt(-2, df=1.01, log=TRUE).
* Probably also improvable when lower_tail = FALSE */
if(P_ok1) {
int it=0;
while(it++ < 10 && (y = dt(q, ndf, FALSE)) > 0 &&
R_FINITE(x = (pt(q, ndf, FALSE, FALSE) - P/2) / y) &&
fabs(x) > 1e-14*fabs(q))
/* Newton (=Taylor 1 term):
* q += x;
* Taylor 2-term : */
q += x * (1. + x * q * (ndf + 1) / (2 * (q * q + ndf)));
}
}
if(neg) q = -q;
return q;
}
double qbinom(double p, double n, double pr, int lower_tail, int log_p)
{
double q, mu, sigma, gamma, z, y;
#ifdef IEEE_754
if (ISNAN(p) || ISNAN(n) || ISNAN(pr))
return p + n + pr;
#endif
if(!R_FINITE(n) || !R_FINITE(pr))
ML_ERR_return_NAN;
/* if log_p is true, p = -Inf is a legitimate value */
if(!R_FINITE(p) && !log_p)
ML_ERR_return_NAN;
if(n != floor(n + 0.5)) ML_ERR_return_NAN;
if (pr < 0 || pr > 1 || n < 0)
ML_ERR_return_NAN;
R_Q_P01_boundaries(p, 0, n);
if (pr == 0. || n == 0) return 0.;
q = 1 - pr;
if(q == 0.) return n; /* covers the full range of the distribution */
mu = n * pr;
sigma = sqrt(n * pr * q);
gamma = (q - pr) / sigma;
#ifdef DEBUG_qbinom
REprintf("qbinom(p=%7g, n=%g, pr=%7g, l.t.=%d, log=%d): sigm=%g, gam=%g\n",
p,n,pr, lower_tail, log_p, sigma, gamma);
#endif
/* Note : "same" code in qpois.c, qbinom.c, qnbinom.c --
* FIXME: This is far from optimal [cancellation for p ~= 1, etc]: */
if(!lower_tail || log_p) {
p = R_DT_qIv(p); /* need check again (cancellation!): */
if (p == 0.) return 0.;
if (p == 1.) return n;
}
/* temporary hack --- FIXME --- */
if (p + 1.01*DBL_EPSILON >= 1.) return n;
/* y := approx.value (Cornish-Fisher expansion) : */
z = qnorm(p, 0., 1., /*lower_tail*/TRUE, /*log_p*/FALSE);
y = floor(mu + sigma * (z + gamma * (z*z - 1) / 6) + 0.5);
if(y > n) /* way off */ y = n;
#ifdef DEBUG_qbinom
REprintf(" new (p,1-p)=(%7g,%7g), z=qnorm(..)=%7g, y=%5g\n", p, 1-p, z, y);
#endif
z = pbinom(y, n, pr, /*lower_tail*/TRUE, /*log_p*/FALSE);
/* fuzz to ensure left continuity: */
p *= 1 - 64*DBL_EPSILON;
if(n < 1e5) return do_search(y, &z, p, n, pr, 1);
/* Otherwise be a bit cleverer in the search */
{
double incr = floor(n * 0.001), oldincr;
do {
oldincr = incr;
y = do_search(y, &z, p, n, pr, incr);
incr = fmax2(1, floor(incr/100));
} while(oldincr > 1 && incr > n*1e-15);
return y;
}
}
void diffhfunc(double* u, double* v, int* n, double* param, int* copula, double* out)
{
int j;
double t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, t11, t12, t14, t15, t16, t18, t22, t24, t25, t27, t28, t32;
double theta = param[0];
//double delta = param[1];
for(j=0;j<*n;j++)
{
if(*copula==0)
{
out[j]=0;
}
else if(*copula==1)
{
t1=qnorm(u[j],0.0,1.0,1,0);
t2=qnorm(v[j],0.0,1.0,1,0);
t3=t1-theta*t2;
t4=1.0-pow(theta,2);
t5=sqrt(t4);
t6=t3/t5;
t7=dnorm(t6,0.0,1.0,0);
t8=-1.0*t2*t5+1.0*t3*theta/t5;
t9=t8/t4;
out[j]=t7*t9;
}
else if(*copula==3)
{
t1 = pow(v[j],-1.0*theta-1.0);
t2 = log(v[j]);
t3 = pow(u[j],-1.0*theta);
t4 = pow(v[j],-1.0*theta);
t5 = t3+t4-1.0;
t6 = -1.0-1/theta;
t7 = pow(t5,1.0*t6);
t8 = theta*theta;
t9 = log(t5);
t10 = log(u[j]);
out[j] = -t1*t2*t7+t1*t7*(1/t8*t9+t6*(-t3*t10-t4*t2)/t5);
}
else if(*copula==4)
{
t1 = log(v[j]);
t2 = pow(-t1,1.0*theta);
t3 = log(u[j]);
t4 = pow(-t3,1.0*theta);
t5 = t2+t4;
t6 = 1/theta;
t7 = pow(t5,1.0*t6);
t8 = theta*theta;
t9 = log(t5);
t10 = 1/t8*t9;
t11 = log(-t1);
t14 = log(-t3);
t16 = t2*t11+t4*t14;
t18 = 1/t5;
t22 = exp(-t7);
t24 = t6-1.0;
t25 = pow(t5,1.0*t24);
t27 = 1/v[j];
t28 = 1/t1;
t32 = t22*t25;
out[j] = t7*(-t10+t6*t16*t18)*t22*t25*t2*t27*t28-t32*(-t10+t24*t16*t18)*t2*t27*t28-t32*t2*t11*t27*t28;
}
else if(*copula==5)
{
t1 = exp(theta);
t2 = theta*u[j];
t3 = exp(t2);
t5 = t1*(t3-1.0);
t6 = theta*v[j];
t8 = exp(t6+t2);
t9 = exp(t6+theta);
t10 = exp(t2+theta);
t11 = t8-t9-t10+t1;
t14 = 1/t11;
t18 = t11*t11;
out[j] = -t5*t14-t1*u[j]*t3*t14+t5/t18*((v[j]+u[j])*t8-(v[j]+1.0)*t9-(u[j]+1.0)*t10+t1);
}
else if(*copula==6)
{
t1 = 1.0-u[j];
t2 = pow(t1,1.0*theta);
t3 = 1.0-v[j];
t4 = pow(t3,1.0*theta);
t5 = t2*t4;
t6 = t2+t4-t5;
t8 = 1/theta-1.0;
t9 = pow(t6,1.0*t8);
t10 = theta*theta;
t12 = log(t6);
t14 = log(t1);
t15 = t2*t14;
t16 = log(t3);
t27 = pow(t3,1.0*theta-1.0);
t7 = 1.0-t2;
t11 = t9*t27;
out[j] = t9*(-1.0/t10*t12+t8*(t15+t4*t16-t15*t4-t5*t16)/t6)*t27*t7+t11*t16*t7-t11*t15;
}
}
}
// ****** update_Data_GS_regres ***********************
//
// Version with possible regression
// ================================
//
// YsM[nP x gg->dim()] ........... on INPUT: current vector of (imputed) log(event times)
// on OUTPUT: updated vector of (augmented) log(event times)
// regresResM[nP x gg->dim()] .... on INPUT: current vector of regression residuals (y - x'beta - z'b))
// on OUTPUT: updated vector of regression residuals
//
// rM[nP] ........................ component labels taking values 0, 1, ..., gg->total_length()-1
//
void
update_Data_GS_regres(double* YsM,
double* regresResM,
const double* y_left,
const double* y_right,
const int* status,
const int* rM,
const Gspline* gg,
const int* nP)
{
int obs, j;
double mu_jk = 0;
double PhiL = 0;
double PhiU = 0;
double u = 0;
double PhiInv = 0;
double stres = 0;
double invsigma[_max_dim];
double invscale[_max_dim];
for (j = 0; j < gg->dim(); j++){
invsigma[j] = 1/gg->sigma(j);
invscale[j] = 1/gg->scale(j);
}
//Rprintf("\nG-spline dim: %d\n", gg->dim());
//Rprintf("mu[0, 0] = %g\n", gg->mu_component(0, 0));
//Rprintf("sigma[0] = %g\n", gg->sigma(0));
//Rprintf("intcpt[0] = %g\n", gg->intcpt(0));
//Rprintf("scale[0] = %g\n", gg->scale(0));
double* y_obs = YsM;
double* regRes = regresResM;
const double* y1 = y_left;
const double* y2 = y_right;
const int* stat = status;
const int* rp = rM;
for (obs = 0; obs < *nP; obs++){
for (j = 0; j < gg->dim(); j++){
switch (*stat){
case 1: /* exactly observed */
break;
case 0: /* right censored */
mu_jk = gg->mu_component(j, *rp);
*regRes -= *y_obs;
stres = (*y1 + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiL = pnorm(stres, 0, 1, 1, 0);
if (PhiL >= 1 - NORM_ZERO){ // censored time irrealistic large (out of the prob. scale)
*y_obs = *y1;
}
else{
if (PhiL <= NORM_ZERO){ // censoring time equal to "zero", generate an exact time from N(mean, variance),
// i.e. from the full not-truncated distribution
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_obs = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
u = runif(0, 1) * (1 - PhiL) + PhiL;
PhiInv = qnorm(u, 0, 1, 1, 0);
if (PhiInv == R_PosInf){ // u was equal to 1, additional check added 16/12/2004
*y_obs = *y1;
}
else{
*y_obs = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
}
}
*regRes += (*y_obs);
break;
case 2: /* left censored */
mu_jk = gg->mu_component(j, *rp);
*regRes -= *y_obs;
stres = (*y1 + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiU = pnorm(stres, 0, 1, 1, 0);
if (PhiU <= NORM_ZERO){ // left censoring time irrealistic low (equal to "zero")
*y_obs = *y1;
}
else{
if (PhiU >= 1 - NORM_ZERO){ // left censoring time equal to "infty", generate an exact time from N(mean, variance),
// i.e. from the full not-truncated distribution
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_obs = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
u = runif(0, 1) * PhiU;
PhiInv = qnorm(u, 0, 1, 1, 0);
if (PhiInv == R_NegInf){ // u was equal to 0, additional check added 16/12/2004
*y_obs = *y1;
}
else{
*y_obs = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
}
}
*regRes += *y_obs;
break;
case 3: /* interval censored */
mu_jk = gg->mu_component(j, *rp);
*regRes -= *y_obs;
stres = (*y1 + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiL = pnorm(stres, 0, 1, 1, 0);
stres = (*y2 + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiU = pnorm(stres, 0, 1, 1, 0);
PhiInv = PhiU - PhiL;
if (PhiInv <= NORM_ZERO){ // too narrow interval, or the interval out of the probability scale
// (both limits in "zero" probability region)
// generate something inbetween
u = runif(0, 1);
*y_obs = *y1 + u*((*y2) - (*y1));
}
else{
if (PhiInv >= 1 - NORM_ZERO){ // too large interval, practically (-infty, +infty), generate an exact time from N(mean, variance)
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_obs = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
u = runif(0, 1) * PhiInv + PhiL;
PhiInv = qnorm(u, 0, 1, 1, 0);
if (!R_finite(PhiInv)){ // u was either zero or one, additional check added 16/12/2004
u = runif(0, 1);
*y_obs = *y1 + u*((*y2) - (*y1));
}
else{
*y_obs = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
}
}
*regRes += *y_obs;
break;
} /** end of switch (status) **/
/*** This section just performs additional checks to prevent simulations with NaN's ***/
if (!R_finite(*y_obs) || !R_finite(*regRes)){
int condit;
REprintf("\nY[%d,%d]=%e, regRes[%d,%d]=%e, r[%d,%d]=%d, status[%d,%d]=%d, stres=%e",
obs, j, *y_obs, obs, j, *regRes, obs, j, *rp, obs, j, *stat, stres);
REprintf("; mean=%e", mu_jk);
REprintf("; invvar=%e", gg->invsigma2(j));
REprintf("\nu=%3.20e, PhiL=%3.20e, PhiU=%3.20e, PhiInv=%3.20e", u, PhiL, PhiU, PhiInv);
REprintf("NORM_ZERO=%3.20e, 1-NORM_ZERO=%3.20e", NORM_ZERO, 1-NORM_ZERO);
switch (*stat){
case 0:
condit = 1*(PhiL >= 1 - NORM_ZERO);
REprintf("\nPhiL >= 1 - NORM_ZERO: %d", condit);
condit = 1*(PhiL <= NORM_ZERO);
REprintf("\nPhiL <= NORM_ZERO: %d", condit);
break;
case 2:
condit = 1*(PhiU >= 1 - NORM_ZERO);
REprintf("\nPhiU >= 1 - NORM_ZERO: %d", condit);
condit = 1*(PhiU <= NORM_ZERO);
REprintf("\nPhiU <= NORM_ZERO: %d", condit);
break;
case 3:
condit = 1*(PhiU-PhiL >= 1 - NORM_ZERO);
REprintf("\nPhiU-PhiL >= 1 - NORM_ZERO: %d", condit);
condit = 1*(PhiU-PhiL <= NORM_ZERO);
REprintf("\nPhiU-PhiL <= NORM_ZERO: %d", condit);
break;
}
REprintf("\n");
throw returnR("Trap in update_Data_GS_regres: NaN generated.", 1);
}
y_obs++;
regRes++;
y1++;
y2++;
stat++;
}
rp++;
}
return;
} /*** end of function update_Data_GS_regres ***/
Boolean
transform1(xgobidata *xg, int *cols, int ncols, float *incr,
float (*domain_adj)(float), float (*inv_domain_adj)(float),
int tfnum, double param)
{
int i, j, k, n;
float min, max, diff, t1, tincr;
float mean, stddev;
float fmedian, ref;
Boolean allequal, tform_ok = true;
double dtmp;
switch (domain_ind) {
case DOMAIN_OK:
*incr = 0;
domain_adj = no_change;
inv_domain_adj = no_change;
break;
case RAISE_MIN_TO_0:
tincr = fabs(xg->lim_raw[ tform_cols[0] ].min);
for (j=0; j<ncols; j++)
if ( (t1=fabs(xg->lim_raw[ tform_cols[j] ].min)) > tincr )
tincr = t1;
*incr = tincr;
domain_adj = raise_min_to_0;
inv_domain_adj = inv_raise_min_to_0;
break;
case RAISE_MIN_TO_1:
tincr = fabs(xg->lim_raw[ tform_cols[0] ].min);
for (j=0; j<ncols; j++)
if ( (t1=fabs(xg->lim_raw[ tform_cols[j] ].min)) > tincr )
tincr = t1;
*incr = tincr;
domain_adj = raise_min_to_1;
inv_domain_adj = inv_raise_min_to_1;
break;
case NEGATE:
*incr = 0.0;
domain_adj = negate;
inv_domain_adj = negate;
break;
default:
*incr = 0;
domain_adj = no_change;
inv_domain_adj = no_change;
}
switch(tfnum)
{
case RESTORE: /* Restore original values -- set domain adj to null */
/*
* If the transformation panel has been initialized, perform
* the restore functions.
*
* Retore all, without regard to rows_in_plot
*/
if (domain_menu_btn != NULL && domain_menu_btn[DOMAIN_OK] != NULL) {
XtCallCallbacks(domain_menu_btn[DOMAIN_OK],
XtNcallback, (XtPointer) xg);
for (n=0; n<ncols; n++) {
j = cols[n];
for (i=0; i<xg->nrows; i++) {
xg->tform1[i][j] = xg->raw_data[i][j];
}
(void) strcpy(xg->collab_tform1[j], xg->collab[j]);
XtVaSetValues(varlabel[j], XtNlabel, xg->collab_tform1[j], NULL);
}
}
break;
case APPLY_ADJ: /* Apply domain adj */
for (n=0; n<ncols; n++) {
j = cols[n];
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
xg->tform1[k][j] = (*domain_adj)(xg->raw_data[k][j]);
}
(void) strcpy(xg->collab_tform1[j], xg->collab[j]);
XtVaSetValues(varlabel[j], XtNlabel, xg->collab_tform1[j], NULL);
}
break;
case POWER: /* Box-Cox power transform family */
if (fabs(param-0) < .001) { /* Natural log */
for (n=0; n<ncols; n++) {
if (!tform_ok) break;
j = cols[n];
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
if ((*domain_adj)(xg->raw_data[k][j]) <= 0) {
fprintf(stderr, "%f %f\n",
xg->raw_data[k][j], (*domain_adj)(xg->raw_data[k][j]));
DOMAIN_ERROR;
show_message(message, xg);
tform_ok = false;
break;
}
}
}
for (n=0; n<ncols; n++) {
j = cols[n];
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
xg->tform1[k][j] = (float)
log((double) ((*domain_adj)(xg->raw_data[k][j])));
}
(void) sprintf(xg->collab_tform1[j], "ln(%s)", xg->collab[j]);
XtVaSetValues(varlabel[j], XtNlabel, xg->collab_tform1[j], NULL);
}
}
else {
for (n=0; n<ncols; n++) {
if (!tform_ok) break;
j = cols[n];
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
dtmp = pow((double) (*domain_adj)(xg->raw_data[k][j]), param);
dtmp = (dtmp - 1.0) / param;
/* If dtmp no good, restore and return */
if (!finite(dtmp)) {
fprintf(stderr, "%f %f %f\n",
xg->raw_data[k][j], (*domain_adj)(xg->raw_data[k][j]), dtmp);
DOMAIN_ERROR;
show_message(message, xg);
fallback(xg);
tform_ok = false;
break;
}
xg->tform1[k][j] = (float) dtmp;
}
(void) sprintf(xg->collab_tform1[j], "B-C(%s,%.2f)",
xg->collab[j], param);
XtVaSetValues(varlabel[j], XtNlabel, xg->collab_tform1[j], NULL);
}
}
break;
case ABSVALUE:
for (n=0; n<ncols; n++) {
j = cols[n];
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
if ((xg->raw_data[k][j] + domain_incr) < 0)
xg->tform1[k][j] = (float)
fabs((double)(*domain_adj)(xg->raw_data[k][j])) ;
else
xg->tform1[k][j] = (*domain_adj)(xg->raw_data[k][j]);
}
(void) sprintf(xg->collab_tform1[j], "Abs(%s)", xg->collab[j]);
XtVaSetValues(varlabel[j], XtNlabel, xg->collab_tform1[j], NULL);
}
break;
case INVERSE: /* 1/x */
for (n=0; n<ncols; n++) {
if (!tform_ok) break;
j = cols[n];
for (i=0; i<xg->nrows; i++) {
k = xg->rows_in_plot[i];
if ((*domain_adj)(xg->raw_data[k][j]) == 0) {
DOMAIN_ERROR;
show_message(message, xg);
tform_ok = false;
break;
}
}
}
for (n=0; n<ncols; n++) {
j = cols[n];
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
xg->tform1[k][j] = (float)
pow((double) (*domain_adj)(xg->raw_data[k][j]),
(double) (-1.0));
}
(void) sprintf(xg->collab_tform1[j], "1/%s", xg->collab[j]);
XtVaSetValues(varlabel[j], XtNlabel, xg->collab_tform1[j], NULL);
}
break;
case LOG10: /* Base 10 log */
for (n=0; n<ncols; n++) {
if (!tform_ok) break;
j = cols[n];
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
if ( (*domain_adj)(xg->raw_data[k][j]) <= 0) {
DOMAIN_ERROR;
show_message(message, xg);
tform_ok = false;
break;
}
}
}
for (n=0; n<ncols; n++) {
j = cols[n];
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
xg->tform1[k][j] = (float)
log10((double) (*domain_adj)(xg->raw_data[k][j]));
}
(void) sprintf(xg->collab_tform1[j], "log10(%s)", xg->collab[j]);
XtVaSetValues(varlabel[j], XtNlabel, xg->collab_tform1[j], NULL);
}
break;
case SCALE: /* Map onto [0,1] */
/* First find min and max; they get updated after transformations */
/* min = max = (*domain_adj)(xg->raw_data[0][cols[0]]);
for (n=0; n<ncols; n++) {
j = cols[n];
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
if ( (ref = (*domain_adj)(xg->raw_data[k][j])) < min)
min = ref;
else if (ref > max) max = ref;
}
}
adjust_limits(&min, &max);
diff = max - min;*/
for (n=0; n<ncols; n++) {
j = cols[n];
min = max = (*domain_adj)(xg->raw_data[0][j]);
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
if ( (ref = (*domain_adj)(xg->raw_data[k][j])) < min)
min = ref;
else if (ref > max) max = ref;
}
adjust_limits(&min, &max);
diff = max - min;
printf("%f, %f, %f\n",min,max,diff);
for (i=0; i<xg->nrows; i++)
{
k = xg->rows_in_plot[i];
xg->tform1[k][j] =
((*domain_adj)(xg->raw_data[k][j]) - min)/diff;
}
(void) sprintf(xg->collab_tform1[j], "%s [0,1]", xg->collab[j]);
XtVaSetValues(varlabel[j], XtNlabel, xg->collab_tform1[j], NULL);
}
break;
case STANDARDIZE: /* (x-mean)/sigma */
/* DOMAIN_ERROR if stddev == 0 */
for (n=0; n<ncols; n++) {
j = cols[n];
mean_stddev(xg, j, domain_adj, &mean, &stddev);
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
xg->tform1[k][j] =
((*domain_adj)(xg->raw_data[k][j]) - mean)/stddev;
}
(void) sprintf(xg->collab_tform1[j], "(%s-m)/s", xg->collab[j]);
XtVaSetValues(varlabel[j], XtNlabel, xg->collab_tform1[j], NULL);
}
break;
case DISCRETE2: /* x>median */
/* refuse to discretize if all values are the same */
for (n=0; n<ncols; n++) {
j = cols[n];
allequal = True;
ref = xg->raw_data[0][cols[j]];
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
if (xg->raw_data[k][j] != ref) {
allequal = False;
break;
}
}
if (allequal) {
DOMAIN_ERROR;
show_message(message, xg);
tform_ok = false;
break;
}
}
/* First find median */
/* Then find the true min and max */
for (n=0; n<ncols; n++) {
j = cols[n];
min = max = (*domain_adj)(xg->raw_data[0][j]);
fmedian = median (xg, xg->raw_data, j);
fmedian = (*domain_adj)(fmedian);
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
if ( (ref = (*domain_adj)(xg->raw_data[k][j])) < min)
min = ref;
else if (ref > max) max = ref;
}
/* }*/
/* This prevents the collapse of the data in a special case */
if (max == fmedian)
fmedian = (min + max)/2.0;
printf("%f %f %f \n",min,max,fmedian);
/* for (n=0; n<ncols; n++) {
j = cols[n];*/
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
xg->tform1[k][j] =
( (*domain_adj)(xg->raw_data[k][j]) > fmedian ) ? 1.0 : 0.0;
}
(void) sprintf(xg->collab_tform1[j], "%s:0,1", xg->collab[j]);
XtVaSetValues(varlabel[j], XtNlabel, xg->collab_tform1[j], NULL);
}
break;
case ZSCORE:
{
float *z_score_data;
float ftmp;
/* Allocate array for z scores */
z_score_data = (float *)
XtMalloc((Cardinal) xg->nrows_in_plot * sizeof(float));
for (n=0; n<ncols; n++) {
float zmean=0, zvar=0;
j = cols[n];
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
ftmp = (*domain_adj)(xg->raw_data[k][j]);
z_score_data[k] = ftmp;
zmean += ftmp;
zvar += (ftmp * ftmp);
}
zmean /= xg->nrows_in_plot;
zvar = (float)sqrt((float)(zvar/xg->nrows_in_plot - zmean*zmean));
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
z_score_data[k] = (z_score_data[k]-zmean)/zvar;
}
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
if (z_score_data[k]>0)
z_score_data[k] = erf(z_score_data[k]/sqrt(2.))/
2.8284271+0.5;
else if (z_score_data[k]<0)
z_score_data[k] = 0.5 - erf((float) fabs((double)
z_score_data[k])/sqrt(2.))/2.8284271;
else
z_score_data[k]=0.5;
}
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
xg->tform1[k][j] = z_score_data[k];
}
(void) sprintf(xg->collab_tform1[j], "zsc(%s)", xg->collab[j]);
XtVaSetValues(varlabel[j], XtNlabel, xg->collab_tform1[j], NULL);
}
XtFree((XtPointer) z_score_data);/* mallika */
}
break;
case NORMSCORE:
case RANK:
{
paird *pairs = (paird *)
XtMalloc ((Cardinal) xg->nrows_in_plot * sizeof (paird));
for (n=0; n<ncols; n++) {
j = cols[n];
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
pairs[k].f = xg->raw_data[i][j];
pairs[k].indx = k;
}
qsort ((char *) pairs, xg->nrows_in_plot, sizeof (paird), pcompare);
for (i=0; i<xg->nrows_in_plot; i++) {
k = xg->rows_in_plot[i];
xg->tform1[pairs[k].indx][j] =
(tfnum == RANK) ?
(float) k :
qnorm ((float) (k+1) / (float) (xg->nrows_in_plot+1));
}
if (tfnum == NORMSCORE)
(void) sprintf(xg->collab_tform2[j],
"normsc(%s)", xg->collab_tform1[j]);
else
(void) sprintf(xg->collab_tform2[j],
"rank(%s)", xg->collab_tform1[j]);
XtVaSetValues(varlabel[j], XtNlabel, xg->collab_tform2[j], NULL);
}
XtFree ((XtPointer) pairs);
}
break;
}
if (tform_ok) {
/* Set tform_tp[] for transformed columns */
for (n=0; n<ncols; n++) {
tform_tp[cols[n]].tform1 = tfnum;
tform_tp[cols[n]].domain_incr = *incr;
tform_tp[cols[n]].param = param;
tform_tp[cols[n]].domain_adj = domain_adj;
tform_tp[cols[n]].inv_domain_adj = inv_domain_adj;
}
}
for (n=0; n<ncols; n++) {
j = cols[n];
(void) strcpy(xg->collab_tform2[j], xg->collab_tform1[j]);
for (i=0; i<xg->nrows; i++) {
xg->tform2[i][j] = xg->tform1[i][j];
}
}
return(tform_ok);
}
//////////////////////////////////////////////////////////////
// Function to compute h-function for vine simulation and estimation
// Input:
// family copula family (0=independent, 1=gaussian, 2=student, 3=clayton, 4=gumbel, 5=frank, 6=joe, 7=BB1, 8=BB7)
// n number of iterations
// u variable for which h-function computes conditional distribution function
// v variable on which h-function conditions
// theta parameter for the copula family
// nu degrees-of-freedom for the students copula
// out output
//////////////////////////////////////////////////////////////
void Hfunc(int* family, int* n, double* u, double* v, double* theta, double* nu, double* out)
{
int j;
double *h;
h = Calloc(*n,double);
double x;
for(j=0;j<*n;j++)
{
if((v[j]==0) | ( u[j]==0)) h[j] = 0;
else if (v[j]==1) h[j] = u[j];
else
{
if(*family==0) //independent
{
h[j] = u[j];
}
else if(*family==1) //gaussian
{
x = (qnorm(u[j],0.0,1.0,1,0) - *theta*qnorm(v[j],0.0,1.0,1,0))/sqrt(1.0-pow(*theta,2.0));
if (isfinite(x))
h[j] = pnorm(x,0.0,1.0,1,0);
else if ((qnorm(u[j],0.0,1.0,1,0) - *theta*qnorm(v[j],0.0,1.0,1,0)) < 0)
h[j] = 0;
else
h[j] = 1;
}
else if(*family==2) //student
{
double t1, t2, mu, sigma2;
t1 = qt(u[j],*nu,1,0); t2 = qt(v[j],*nu,1,0); mu = *theta*t2; sigma2 = ((*nu+t2*t2)*(1.0-*theta*(*theta)))/(*nu+1.0);
h[j] = pt((t1-mu)/sqrt(sigma2),*nu+1.0,1,0);
}
else if(*family==3) //clayton
{
if(*theta == 0) h[j] = u[j] ;
if(*theta < XEPS) h[j] = u[j] ;
else
{
x = pow(u[j],-*theta)+pow(v[j],-*theta)-1.0 ;
h[j] = pow(v[j],-*theta-1.0)*pow(x,-1.0-1.0/(*theta));
if(*theta < 0)
{
if(x < 0) h[j] = 0;
}
}
}
else if(*family==4) //gumbel
{
if(*theta == 1) h[j] = u[j] ;
else
{
h[j] = -(exp(-pow(pow(-log(v[j]),*theta)+pow(-log(u[j]),*theta),1.0/(*theta)))*pow(pow(-log(v[j]),*theta)+pow(-log(u[j]),*theta),1.0/(*theta)-1.0)*pow(-log(v[j]),*theta))/(v[j]*log(v[j]));
}
}
else if(*family==5) //frank
{
if(*theta==0) h[j]=u[j];
else
{
h[j] = -(exp(*theta)*(exp(*theta*u[j])-1.0))/(exp(*theta*v[j]+*theta*u[j])-exp(*theta*v[j]+*theta)-exp(*theta*u[j]+*theta)+exp(*theta));
}
}
else if(*family==6) //joe
{
if(*theta==1) h[j]=u[j];
else
{
h[j] = pow(pow(1.0-u[j],*theta) + pow(1.0-v[j],*theta) - pow(1.0-u[j],*theta)*pow(1.0-v[j],*theta),1.0/(*theta)-1) * pow(1.0-v[j],*theta-1.0)*(1-pow(1-u[j],*theta));
}
}
else if(*family==7) //BB1
{
double* param;
param = Calloc(2,double);
param[0]=*theta;
param[1]=*nu;
int T=1;
if(*nu==1)
{
if(*theta==0) h[j]=u[j];
else h[j]=pow(pow(u[j],-*theta)+pow(v[j],-*theta)-1,-1/(*theta)-1)*pow(v[j],-*theta-1);
}
else if(*theta==0)
{
h[j]=-(exp(-pow(pow(-log(v[j]),*nu)+pow(-log(u[j]),*nu),1.0/(*nu)))*pow(pow(-log(v[j]),*nu)+pow(-log(u[j]),*nu),1.0/(*nu)-1.0)*pow(-log(v[j]),*nu))/(v[j]*log(v[j]));
}
else
{
pcondbb1(&v[j],&u[j],&T,param,&h[j]);
}
Free(param);
}
else if(*family==8) //BB6
{
double* param;
param = Calloc(2,double);
param[0]=*theta;
param[1]=*nu;
int T=1;
if(*theta==1)
{
if(*nu==1) h[j]=u[j];
else h[j]=-(exp(-pow(pow(-log(v[j]),*nu)+pow(-log(u[j]),*nu),1.0/(*nu)))*pow(pow(-log(v[j]),*nu)+pow(-log(u[j]),*nu),1.0/(*nu)-1.0)*pow(-log(v[j]),*nu))/(v[j]*log(v[j]));
}
else if(*nu==1)
{
h[j]=pow(pow(1.0-u[j],*theta) + pow(1.0-v[j],*theta) - pow(1.0-u[j],*theta)*pow(1.0-v[j],*theta),1.0/(*theta)-1) * pow(1.0-v[j],*theta-1.0)*(1-pow(1-u[j],*theta));
}
else
{
pcondbb6(&v[j],&u[j],&T,param,&h[j]);
}
Free(param);
}
// ****** update_Data_GS_regres_misclass ***********************
//
// Version with possible regression and misclassification of the event status
// ============================================================================
//
// REMARK to calculation of iPML: iPML calculated here conditions also by component allocations.
// This is different to 'iPML_misclass_GJK' function below
// which integrates the component allocations out by using the
// whole mixture in the expression for iPML.
//
// Created in 201305 by modification of 'update_Data_GS_regres' function.
// -----------------------------------------------------------------------------
//
// This function assumes that gg->dim() = 1.
//
// YsM[nP x gg->dim()] ........... on INPUT: current vector of (imputed) log(event times)
// on OUTPUT: updated vector of (augmented) log(event times)
// regresResM[nP x gg->dim()] .... on INPUT: current vector of regression residuals (y - x'beta - z'b))
// on OUTPUT: updated vector of regression residuals
// n00[nExaminer * nFactor] ...... INPUT: whatsever
// OUTPUT: numbers of (0-0) correctly classified events for each examiner:factor
// n10[nExaminer * nFactor] ...... INPUT: whatsever
// OUTPUT: numbers of (Classification = 1 | True = 0) incorrectly classified events for each examiner:factor
// n01[nExaminer * nFactor] ...... INPUT: whatsever
// OUTPUT: numbers of (Classification = 0 | True = 1) incorrectly classified events for each examiner:factor
// n11[nExaminer * nFactor] ...... INPUT: whatsever
// OUTPUT: numbers of (1-1) correctly classified events for each examiner:factor
//
// iPML[nExaminer * nFactor] ..... INPUT: whatsever
// OUTPUT: individual contributions needed to calculate the pseudo marginal likelihood and also the deviance
//
// dwork[(1 + max(nvisit)) * 6] .. working array
//
// sens[nExaminer * nFactor]...... sensitivities for each examiner:factor
// spec[nExaminer * nFactor]...... specificities for each examiner:factor
// logvtime[nP * sum(nvisit)] .... logarithms of visit times for each observation
// status[nP * sum(nvisit)] ...... classified event status for each visit
//
// nvisit[nP] .................... numbers of visits for each observation
// Examiner[nP * sum(nvisit)] .... examiner (0, 1, ..., nExaminer - 1) identification at each visit
// Factor[nP * sum(nvisit)] ...... factor (0, 1, ..., nFactor - 1) identification at each visit
//
// rM[nP] ........................ component labels taking values 0, 1, ..., gg->total_length()-1
//
void
update_Data_GS_regres_misclass(double* YsM,
double* regresResM,
int* n00,
int* n10,
int* n01,
int* n11,
double* iPML,
double* dwork,
const double* sens,
const double* spec,
const double* logvtime,
const int* status,
const int* nExaminer,
const int* nFactor,
const int* nvisit,
const int* maxnvisit,
const int* Examiner,
const int* Factor,
const int* rM,
const Gspline* gg,
const int* nP)
{
if (gg->dim() > 1) REprintf("update_Data_GS_regres_misclass: Error, not implemented for gg->dim() > 1.\n");
/*** Some general variables ***/
int obs, m, k, L;
double mu_i = 0;
double u = 0;
double Phi = 0;
double stres_sampled = 0;
double invsigma_invscale = 1 / (gg->sigma(0) * gg->scale(0));
/*** Working arrays and related variables ***/
double *A = dwork; /* A numbers */
double *cumInt = A + (1 + *maxnvisit); /* cumsum(A * int_{y_{k-1}}^{y_k} f(s)ds), the last is the normalizing constant */
/* and also the value of iPML */
double *cprod_sens = cumInt + (1 + *maxnvisit); /* cumulative product needed for 'A's based on sensitivities */
double *cprod_spec = cprod_sens + (1 + *maxnvisit); /* cumulative product needed for 'A's based on specificities */
double *stres_cut = cprod_spec + (1 + *maxnvisit); /* limits of intervals on the scale of standardized residuals */
double *Phi_cut = stres_cut + (1 + *maxnvisit); /* Phi(stres_cut) */
double *A_k;
double *cumInt_k;
double *cprod_sens_k;
double *cprod_spec_k;
double *stres_cut_k;
double *Phi_cut_k;
/*** Reset classification matrices ***/
int* n00P = n00;
int* n10P = n10;
int* n01P = n01;
int* n11P = n11;
for (m = 0; m < *nExaminer * *nFactor; m++){
*n00P = 0;
*n10P = 0;
*n01P = 0;
*n11P = 0;
n00P++;
n10P++;
n01P++;
n11P++;
}
/*** Main loop over observations ***/
double* y_i = YsM;
double* regRes_i = regresResM;
double* iPML_i = iPML;
const int* nvisit_i = nvisit;
const double* logvtime_i = logvtime;
const double* logvtime_ik;
const int* status_i = status;
const int* status_ik;
const int* Examiner_i = Examiner;
const int* Examiner_ik;
const int* Factor_i = Factor;
const int* Factor_ik;
const int* r_i = rM;
for (obs = 0; obs < *nP; obs++){
mu_i = gg->mu_component(0, *r_i);
*regRes_i -= *y_i;
/*** Calculate cumulative products based on specificities needed for 'A' numbers ***/
cprod_spec_k = cprod_spec;
*cprod_spec_k = 1.0; /* k = 0*/
cprod_spec_k++;
status_ik = status_i;
Examiner_ik = Examiner_i;
Factor_ik = Factor_i;
for (k = 1; k <= *nvisit_i; k++){
*cprod_spec_k = *(cprod_spec_k - 1) * (*status_ik == 1 ? (1 - spec[*nFactor * *Examiner_ik + *Factor_ik]) : spec[*nFactor * *Examiner_ik + *Factor_ik]);
cprod_spec_k++;
status_ik++;
Examiner_ik++;
Factor_ik++;
}
/*** Calculate cumulative products based on sensitivities needed for 'A' numbers ***/
cprod_sens_k = cprod_sens + *nvisit_i;
*cprod_sens_k = 1.0; /* k = nvisit */
cprod_sens_k--;
status_ik--;
Examiner_ik--;
Factor_ik--;
for (k = *nvisit_i - 1; k >= 0; k--){
*cprod_sens_k = *(cprod_sens_k + 1) * (*status_ik == 1 ? sens[*nFactor * *Examiner_ik + *Factor_ik] : (1 - sens[*nFactor * *Examiner_ik + *Factor_ik]));
cprod_sens_k--;
status_ik--;
Examiner_ik--;
Factor_ik--;
}
/*** Calculate the 'A' numbers and 'cumInt' for this observation ***/
A_k = A;
cprod_sens_k = cprod_sens;
cprod_spec_k = cprod_spec;
cumInt_k = cumInt;
stres_cut_k = stres_cut;
Phi_cut_k = Phi_cut;
logvtime_ik = logvtime_i;
/** k = 0: first visit - like left-censored) **/
*A_k = *cprod_sens_k * *cprod_spec_k;
*stres_cut_k = (*logvtime_ik + (*regRes_i) - gg->intcpt(0) - gg->scale(0) * mu_i) * invsigma_invscale;
*Phi_cut_k = pnorm(*stres_cut_k, 0, 1, 1, 0);
*cumInt_k = *A_k * *Phi_cut_k;
A_k++;
cprod_sens_k++;
cprod_spec_k++;
cumInt_k++;
stres_cut_k++;
Phi_cut_k++;
logvtime_ik++;
/** k = 1, ..., *nvisit_i - 1: like interval-censored **/
for (k = 1; k < *nvisit_i; k++){
*A_k = *cprod_sens_k * *cprod_spec_k;
*stres_cut_k = (*logvtime_ik + (*regRes_i) - gg->intcpt(0) - gg->scale(0) * mu_i) * invsigma_invscale;
*Phi_cut_k = pnorm(*stres_cut_k, 0, 1, 1, 0);
*cumInt_k = *(cumInt_k - 1) + *A_k * (*Phi_cut_k - *(Phi_cut_k - 1));
A_k++;
cprod_sens_k++;
cprod_spec_k++;
cumInt_k++;
stres_cut_k++;
Phi_cut_k++;
logvtime_ik++;
}
/** k = *nvisit_i: like right-censored **/
*A_k = *cprod_sens_k * *cprod_spec_k;
*cumInt_k = *(cumInt_k - 1) + *A_k * (1 - *(Phi_cut_k - 1));
/** Normalizing constant and also iPML **/
*iPML_i = *cumInt_k;
/** Debuging section **/
//if (obs == 5){
// Rprintf("alpha <- c("); for (k = 0; k < *nFactor * *nExaminer; k++) Rprintf("%g, ", sens[k]); Rprintf(")\n");
// Rprintf("eta <- c("); for (k = 0; k < *nFactor * *nExaminer; k++) Rprintf("%g, ", spec[k]); Rprintf(")\n");
// Rprintf("nvisit = %d\n", *nvisit_i);
// Rprintf(" logv <- c("); for (k = 0; k < *nvisit_i; k++) Rprintf("%g, ", logvtime_i[k]); Rprintf(")\n");
// Rprintf(" stres <- c("); for (k = 0; k < *nvisit_i; k++) Rprintf("%g, ", stres_cut[k]); Rprintf(")\n");
// Rprintf(" Phi <- c("); for (k = 0; k < *nvisit_i; k++) Rprintf("%g, ", Phi_cut[k]); Rprintf(")\n");
// Rprintf(" Y <- c("); for (k = 0; k < *nvisit_i; k++) Rprintf("%d, ", status_i[k]); Rprintf(")\n");
// Rprintf(" A <- c("); for (k = 0; k <= *nvisit_i; k++) Rprintf("%g, ", A[k]); Rprintf(")\n");
// Rprintf(" cumInt <- c("); for (k = 0; k <= *nvisit_i; k++) Rprintf("%g, ", cumInt[k]); Rprintf(")\n\n");
//}
/** Sample a uniform random variable **/
u = runif(0, 1);
/** Find out to which piece the 'u' value points out **/
cumInt_k = cumInt;
A_k = A;
//stres_cut_k = stres_cut;
Phi_cut_k = Phi_cut;
for (L = 0; L < *nvisit_i; L++){
if (u <= *cumInt_k / *iPML_i) break;
cumInt_k++;
A_k++;
//stres_cut_k++;
Phi_cut_k++;
}
/*** Now: L = 0: u belongs to piece (-infty, vtime[0]], A_k = A[0], stres_cut_k = stres[0] ***/
/*** L = 1: u belongs to piece (vtime[0], vtime[1]], A_k = A[1], stres_cut_k = stres[1] ***/
/*** ... ***/
/*** L = nvisit - 1 = K - 1: u belongs to piece (vtime[K-2], vtime[K-1]], A_k = A[K-1], stres_cut_k = stres[K-1] ***/
/*** L = nvisit = K : u belongs to piece (vtime[K-1], infty), A_k = A[K], stres_cut_k = N.A. ***/
/*** Get the sampled value of the standardized residual ***/
if (L == 0){ /*** Like LEFT-CENSORED observation ***/
Phi = (*iPML_i * u) / *A_k;
}else{ /*** L = 1, ..., nvisit_i: Like INTERVAL or RIGHT-CENSORED observation ***/
Phi = (*iPML_i * u - *(cumInt_k - 1)) / *A_k + *(Phi_cut_k - 1);
}
if (Phi <= NORM_ZERO){ // PROBLEM1: stres_sampled = -infty
stres_sampled = -QNORM_ONE;
}else{
if (Phi >= 1 - NORM_ZERO){ // PROBLEM2: stres_sampled = infty
stres_sampled = QNORM_ONE;
}else{ // NO PROBLEMS
stres_sampled = qnorm(Phi, 0, 1, 1, 0);
}
}
/*** Calculate the sampled value of the log event time and the regression residual ***/
*y_i = gg->sigma(0) * gg->scale(0) * stres_sampled - *regRes_i + gg->intcpt(0) + gg->scale(0) * mu_i;
*regRes_i += *y_i;
/*** Update the classification matrices ***/
/*** Shift pointers logvtime_i, status_i, Examiner_i, Factor_i at the same time. ***/
for (k = 0; k < *nvisit_i; k++){
if (*y_i <= *logvtime_i){ /*** True status is 1. ***/
if (*status_i == 1){ /** Correct (1, 1) **/
n11[*nFactor * *Examiner_i + *Factor_i] += 1;
}else{ /** Incorrect (0, 1) **/
n01[*nFactor * *Examiner_i + *Factor_i] += 1;
}
}else{ /*** True status is 0. ***/
if (*status_i == 1){ /** Incorrect (1, 0) **/
n10[*nFactor * *Examiner_i + *Factor_i] += 1;
}else{ /** Correct (0, 0) **/
n00[*nFactor * *Examiner_i + *Factor_i] += 1;
}
}
logvtime_i++;
status_i++;
Examiner_i++;
Factor_i++;
}
/*** Shift remaining pointers ***/
y_i++;
regRes_i++;
r_i++;
nvisit_i++;
iPML_i++;
}
return;
} /*** end of function update_Data_GS_regres_misclass ***/
void diffhfunc_v(double* u, double* v, int* n, double* param, int* copula, double* out)
{
int j, k=1;
double t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, t12, t13, t15, t16, t18, t19, t20, t21, t22, t27, t33;
double theta = param[0];
for(j=0;j<*n;j++)
{
if(*copula==0)
{
out[j]=0;
}
else if(*copula==1)
{
t1=qnorm(u[j],0.0,1.0,1,0);
t2=qnorm(v[j],0.0,1.0,1,0);
t3=t1-theta*t2;
t4=1.0-pow(theta,2);
t5=sqrt(t4);
t6=t3/t5;
t7=dnorm(t6,0.0,1.0,0);
t8=sqrt(2.0*pi);
t9=pow(t2,2);
t10=exp(-t9/2.0);
out[j]=t7*t8*(-theta)/t5/t10;
}
else if(*copula==2)
{
diffhfunc_v_tCopula_new(&u[j], &v[j], &k, param, copula, &out[j]);
}
else if(*copula==3)
{
t1 = -theta-1.0;
t2 = pow(v[j],1.0*t1);
t4 = 1/v[j];
t5 = pow(u[j],-1.0*theta);
t6 = pow(v[j],-1.0*theta);
t7 = t5+t6-1.0;
t9 = -1.0-1/theta;
t10 = pow(t7,1.0*t9);
out[j] = t10*t4*t1*t2-1/t7*t4*theta*t6*t9*t10*t2;
}
else if(*copula==4)
{
t3 = log(u[j]);
t4 = pow(-t3,1.0*theta);
t5 = log(v[j]);
t6 = pow(-t5,1.0*theta);
t7 = t4+t6;
t8 = 1/theta;
t9 = pow(t7,1.0*t8);
t10 = t6*t6;
t12 = v[j]*v[j];
t13 = 1/t12;
t15 = t5*t5;
t16 = 1/t15;
t18 = t16/t7;
t19 = exp(-t9);
t20 = t8-1.0;
t21 = pow(t7,1.0*t20);
t22 = t19*t21;
t27 = theta*t13;
t33 = t6*t13;
out[j] = t9*t10*t13*t18*t22-t22*t20*t10*t27*t18-t22*t6*t27*t16+t22*t33/t5+t22*t33*t16;
}
else if(*copula==5)
{
t1 = exp(theta);
t2 = theta*u[j];
t3 = exp(t2);
t6 = theta*v[j];
t8 = exp(t6+t2);
t10 = exp(t6+theta);
t12 = exp(t2+theta);
t13 = pow(t8-t10-t12+t1,2.0);
out[j] = t1*(t3-1.0)/t13*(theta*t8-theta*t10);
}
else if(*copula==6)
{
t2 = pow(1.0-u[j],1.0*theta);
t3 = 1.0-v[j];
t4 = pow(t3,1.0*theta);
t5 = t2*t4;
t6 = t2+t4-t5;
t8 = 1/theta-1.0;
t9 = pow(t6,1.0*t8);
t12 = 1/t3;
t19 = theta-1.0;
t20 = pow(t3,1.0*t19);
t22 = 1.0-t2;
out[j] = t9*t8*(-t4*theta*t12+t5*theta*t12)/t6*t20*t22-t9*t20*t19*t12*t22;
}
}
}
/**
* Calculates the Shapiro-Wilk univariate normality test.
*
* @param double *vector
* @param int n
* @param double *w
* @param double *pw
* @param int *ifault
*/
void swilk(double *vector, int n, double *w, double *pw, int *ifault) {
// Create a copy of the vector and sort it.
double * x = (double *) malloc(sizeof(double) * n);
memcpy(x, vector, sizeof(double) * n);
// Sort the incoming vector
quickSortD(x, n);
int nn2 = n / 2;
double a[nn2 + 1]; /* 1-based */
/*
* ALGORITHM AS R94 APPL. STATIST. (1995) vol.44, no.4, 547-551.
* Calculates the Shapiro-Wilk W test and its significance level
*/
double small = 1e-19;
// Polynomial coefficients.
double g[2] = { -2.273, 0.459 };
double c1[6] = { 0.0, 0.221157, -0.147981, -2.07119, 4.434685, -2.706056 };
double c2[6] = { 0.0, 0.042981, -0.293762, -1.752461, 5.682633, -3.582633 };
double c3[4] = { 0.544, -0.39978, 0.025054, -6.714e-4 };
double c4[4] = { 1.3822, -0.77857, 0.062767, -0.0020322 };
double c5[4] = { -1.5861, -0.31082, -0.083751, 0.0038915 };
double c6[3] = { -0.4803, -0.082676, 0.0030302 };
// Local variables.
int i, j, i1;
double ssassx, summ2, ssumm2, gamma, range;
double a1, a2, an, m, s, sa, xi, sx, xx, y, w1;
double fac, asa, an25, ssa, sax, rsn, ssx, xsx;
*pw = 1.0;
if (n < 3) {
free(x);
char message[100] = "You must have at least 3 samples for Shapiro Wilk's normality test.";
handle_warning(message);
*ifault = 1;
return;
}
an = (double) n;
if (n == 3) {
a[1] = 0.70710678; // = sqrt(1/2)
}
else {
an25 = an + 0.25;
summ2 = 0.0;
for (i = 1; i <= nn2; i++) {
a[i] = qnorm((i - 0.375) / an25, 0.0, 1.0, 1, 0);
double r__1 = a[i];
summ2 += r__1 * r__1;
}
summ2 *= 2.0;
ssumm2 = sqrt(summ2);
rsn = 1.0 / sqrt(an);
a1 = poly(c1, 6, rsn) - a[1] / ssumm2;
// Normalize a[]
if (n > 5) {
i1 = 3;
a2 = -a[2] / ssumm2 + poly(c2, 6, rsn);
fac = sqrt((summ2 - 2.0 * (a[1] * a[1]) - 2.0 * (a[2] * a[2]))
/ (1.0 - 2.0 * (a1 * a1) - 2.0 * (a2 * a2)));
a[2] = a2;
}
else {
i1 = 2;
fac = sqrt((summ2 - 2. * (a[1] * a[1])) / ( 1. - 2. * (a1 * a1)));
}
a[1] = a1;
for (i = i1; i <= nn2; i++) {
a[i] /= - fac;
}
}
// Check for zero range.
range = x[n - 1] - x[0];
if (range < small) {
free(x);
char message[100] = "Range of values is too small for Shapiro Wilk's normality test.";
handle_warning(message);
*ifault = 6;
return;
}
// Check for correct sort order on range - scaled X
/* *ifault = 7; <-- a no-op, since it is changed below, in ANY CASE! */
*ifault = 0;
xx = x[0] / range;
sx = xx;
sa = -a[1];
for (i = 1, j = n - 1; i < n; j--) {
xi = x[i] / range;
if (xx - xi > small) {
/* Fortran had: print *, "ANYTHING"
* but do NOT; it *does* happen with sorted x (on Intel GNU/linux 32bit):
* shapiro.test(c(-1.7, -1,-1,-.73,-.61,-.5,-.24, .45,.62,.81,1))
*/
char message[100] = "Incorrect sort order on range for Shapiro Wilk's normality test.";
handle_warning(message);
*ifault = 7;
}
sx += xi;
i++;
if (i != j) {
sa += sign(i - j) * a[std::min(i, j)];
}
xx = xi;
}
if (n > 5000) {
char message[100] = "You must have no more than 5000 samples for Shapiro Wilk's normality test.";
handle_warning(message);
*ifault = 2;
}
// Calculate W statistic as squared correlation between data and coefficients
sa /= n;
sx /= n;
ssa = ssx = sax = 0.;
for (i = 0, j = n - 1; i < n; i++, j--) {
if (i != j) {
asa = sign(i - j) * a[1 + std::min(i, j)] - sa;
}
else {
asa = -sa;
}
xsx = x[i] / range - sx;
ssa += asa * asa;
ssx += xsx * xsx;
sax += asa * xsx;
}
// W1 equals (1-W) calculated to avoid excessive rounding error
// for W very near 1 (a potential problem in very large samples)
ssassx = sqrt(ssa * ssx);
w1 = (ssassx - sax) * (ssassx + sax) / (ssa * ssx);
*w = 1.0 - w1;
// Calculate significance level for W
if (n == 3) {/* exact P value : */
double pi6 = 1.90985931710274, /* = 6/pi */
stqr = 1.04719755119660; /* = asin(sqrt(3/4)) */
*pw = pi6 * (asin(sqrt(*w)) - stqr);
if(*pw < 0.0) {
*pw = 0.0;
}
free(x);
return;
}
y = log(w1);
xx = log(an);
if (n <= 11) {
gamma = poly(g, 2, an);
if (y >= gamma) {
*pw = 1e-99;/* an "obvious" value, was 'small' which was 1e-19f */
free(x);
return;
}
y = -log(gamma - y);
m = poly(c3, 4, an);
s = exp(poly(c4, 4, an));
}
else {/* n >= 12 */
m = poly(c5, 4, xx);
s = exp(poly(c6, 3, xx));
}
// DBG printf("c(w1=%g, w=%g, y=%g, m=%g, s=%g)\n",w1,*w,y,m,s);
*pw = pnorm(y, m, s, 0/* upper tail */, 0);
free(x);
}
/* Group sequential probability computation per Jennison & Turnbull
Computes upper bound to have input crossing probabilities given fixed input lower bound.
xnanal- # of possible analyses in the group-sequential designs
(interims + final)
xtheta- drift parameter
I - statistical information available at each analysis
a - lower cutoff points for z statistic at each analysis (input)
b - upper cutoff points for z statistic at each analysis (output)
problo- output vector with probability of rejecting (Z<aj) at
jth interim analysis, j=1...nanal
probhi- input vector with probability of rejecting (Z>bj) at
jth interim analysis, j=1...nanal
tol - relative change between iterations required to stop for 'convergence'
xr - controls # of grid points for numerical integration per Jennison & Turnbull
they recommend r=17 (r=18 is default - a little more accuracy)
retval- error flag returned; 0 if convergence; 1 indicates error
printerr- 1 if error messages to be printed - other values suppress printing
*/
void gsbound1(int *xnanal,double *xtheta,double *I,double *a,double *b,double *problo,
double *probhi,double *xtol,int *xr,int *retval,int *printerr)
{ int i,ii,j,m1,m2,r,nanal;
double plo=0.,phi,dphi,btem=0.,btem2,rtdeltak,rtIk,rtIkm1,xlo,xhi,theta,mu,tol,bdelta;
/* note: should allocat zwk & wwk dynamically...*/
double 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]; theta= xtheta[0]; tol=xtol[0];
if (nanal < 1 || r<1 || r>MAXR)
{ retval[0]=1;
if (*printerr)
{ Rprintf("gsbound1 error: illegal argument");
if (nanal<1) Rprintf("; nanal=%d--must be > 0",nanal);
if (r<1 || r> MAXR) Rprintf("; r=%d--must be >0 and <84",r);
Rprintf("\n");
}
return;
}
rtIk=sqrt(I[0]);
mu=rtIk*theta; /* mean of normalized statistic at 1st interim */
problo[0]=pnorm(mu-a[0],0.,1.,0,0); /* probability of crossing lower bound at 1st interim */
if (probhi[0] <= 0.) b[0]=EXTREMEZ;
else b[0]=qnorm(probhi[0],mu,1,0,0); /* upper bound at 1st interim */
if (nanal==1) {retval[0]=0; return;}
/* set up work vectors */
z1=zwk; w1=wwk; h=hwk;
z2=zwk2; w2=wwk2; h2=hwk2;
if (DEBUG) Rprintf("r=%d mu=%lf a[0]=%lf b[0]=%lf\n",r,mu,a[0],b[0]);
m1=gridpts(r,mu,a[0],b[0],z1,w1);
h1(theta,m1,w1,I[0],z1,h);
/* use Newton-Raphson to find subsequent interim analysis cutpoints */
retval[0]=0;
for(i=1;i<nanal;i++)
{ rtIkm1=rtIk; rtIk=sqrt(I[i]); mu=rtIk*theta; rtdeltak=sqrt(I[i]-I[i-1]);
if (probhi[i] <= 0.) btem2=EXTREMEZ;
else btem2=qnorm(probhi[i],mu,1.,0,0); bdelta=1.; j=0;
while((bdelta>tol) && j++ < 20)
{ phi=0.; dphi=0.; plo=0.;
btem=btem2;
if (DEBUG) Rprintf("i=%d m1=%d\n",i,m1);
/* compute probability of crossing boundaries & their derivatives */
for(ii=0;ii<=m1;ii++)
{ xhi=(z1[ii]*rtIkm1-btem*rtIk+theta*(I[i]-I[i-1]))/rtdeltak;
phi += pnorm(xhi,0.,1.,1,0)*h[ii];
xlo=(z1[ii]*rtIkm1-a[i]*rtIk+theta*(I[i]-I[i-1]))/rtdeltak;
plo += pnorm(xlo,0.,1.,0,0)*h[ii];
dphi-=h[ii]*exp(-xhi*xhi/2)/2.506628275*rtIk/rtdeltak;
if (DEBUG) Rprintf("m1=%d ii=%d xhi=%lf phi=%lf xlo=%lf plo=%lf dphi=%lf\n",m1,ii,xhi,phi,xlo,plo,dphi);
}
/* use 1st order Taylor's series to update boundaries */
/* maximum allowed change is 1 */
/* maximum value allowed is EXTREMEZ */
if (DEBUG)
Rprintf("i=%2d j=%2d plo=%lf btem=%lf phi=%lf dphi=%lf\n",i,j,plo,btem,phi,dphi);
bdelta=probhi[i]-phi;
if (bdelta<dphi) btem2=btem+1.;
else if (bdelta > -dphi) btem2=btem-1.;
else btem2=btem+(probhi[i]-phi)/dphi;
if (btem2>EXTREMEZ) btem2=EXTREMEZ;
else if (btem2< -EXTREMEZ) btem2= -EXTREMEZ;
bdelta=btem2-btem; if (bdelta<0) bdelta= -bdelta;
}
b[i]=btem;
problo[i]=plo;
/* if convergence did not occur, set flag for return value */
if (bdelta > tol)
{ if (*printerr) Rprintf("gsbound1 error: No convergence for boundary for interim %d; I=%7.0lf; last 2 upper boundary values: %lf %lf\n",
i+1,I[i],btem,btem2);
retval[0]=1;
}
if (i<nanal-1)
{ 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;
} }
return;
}
/**
* Simulate a truncated Normal random variable
*
* @param m mean of the untruncated normal
* @param sd standard deviation of the untruncated normal
* @param lb left bound of the truncated normal
* @param rb right bound of the truncated normal
*
* @return one simulated truncated normal
*/
static R_INLINE double rtnorm(double m, double sd, double lb, double rb){
double u = runif(R_FINITE(lb) ? pnorm(lb, m, sd, 1, 0) : 0.0,
R_FINITE(rb) ? pnorm(rb, m, sd, 1, 0) : 1.0);
return qnorm(u, m, sd, 1, 0);
}
