spc/0000755000175100001440000000000012656106047011064 5ustar hornikusersspc/src/0000755000175100001440000000000012655133155011652 5ustar hornikusersspc/src/sewma_crit_prerun.c0000644000175100001440000000405212655133155015547 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 #define fixed 0 #define unbiased 1 double seU_crit_prerun_SIGMA(double l, double L0, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double se2fu_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); int se2_crit_prerun_SIGMA(double l, double L0, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seUR_crit_prerun_SIGMA(double l, double L0, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seLR_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); void sewma_crit_prerun ( int *ctyp, int *ltyp, double *l, int *L0, double *cl0, double *cu0, double *hs, double *sigma, int *df1, int *r, int *qm1, int *df2, int *qm2, double *truncate, int *tail_approx, double *c_error, double *a_error, double *c_values) { int result=0; double cl=0., cu=1.; if ( *ctyp==ewmaU ) { cu = seU_crit_prerun_SIGMA(*l, *L0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate); cl = 0.; } if ( *ctyp==ewmaUR ) { cu = seUR_crit_prerun_SIGMA(*l, *L0, *cl0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate); cl = *cl0; } if ( *ctyp==ewmaLR ) { cl = seLR_crit_prerun_SIGMA(*l, *L0, *cu0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate); cu = *cu0; } if ( *ctyp==ewma2 ) { if ( *ltyp==fixed ) { cl = se2fu_crit_prerun_SIGMA(*l, *L0, *cu0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate); cu = *cu0; } if ( *ltyp==unbiased ) result = se2_crit_prerun_SIGMA(*l, *L0, &cl, &cu, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate); } if ( result != 0 ) warning("trouble with se2_crit_prerun_SIGMA called from sewma_crit_prerun [package spc]"); c_values[0] = cl; c_values[1] = cu; } spc/src/sewma_q_crit_prerun.c0000644000175100001440000000512312655133155016067 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 #define fixed 0 #define unbiased 1 double seU_q_crit_prerun_SIGMA(double l, int L0, double alpha, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double se2fu_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); int se2_q_crit_prerun_SIGMA(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double seUR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double seLR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); void sewma_q_crit_prerun ( int *ctyp, int *ltyp, double *l, int *L0, double *alpha, double *cl0, double *cu0, double *hs, double *sigma, int *df1, int *r, int *qm1, int *df2, int *qm2, double *truncate, int *tail_approx, double *c_error, double *a_error, double *c_values) { int result=0; double cl=0., cu=1.; if ( *ctyp==ewmaU ) { cu = seU_q_crit_prerun_SIGMA(*l, *L0, *alpha, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate, *tail_approx, *c_error, *a_error); cl = 0.; } if ( *ctyp==ewmaUR ) { cu = seUR_q_crit_prerun_SIGMA(*l, *L0, *alpha, *cl0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate, *tail_approx, *c_error, *a_error); cl = *cl0; } if ( *ctyp==ewmaLR ) { cl = seLR_q_crit_prerun_SIGMA(*l, *L0, *alpha, *cu0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate, *tail_approx, *c_error, *a_error); cu = *cu0; } if ( *ctyp==ewma2 ) { if ( *ltyp==fixed ) { cl = se2fu_q_crit_prerun_SIGMA(*l, *L0, *alpha, *cu0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate, *tail_approx, *c_error, *a_error); cu = *cu0; } if ( *ltyp==unbiased ) result = se2_q_crit_prerun_SIGMA(*l, *L0, *alpha, &cl, &cu, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate, *tail_approx, *c_error, *a_error); } if ( result != 0 ) warning("trouble with se2_crit called from sewma_q_crit_prerun [package spc]"); c_values[0] = cl; c_values[1] = cu; } spc/src/sewma_res_arl.c0000644000175100001440000000064512655133155014646 0ustar hornikusers#include #include #include #include double seU_iglarl_RES(double l, double cu, double hs, double sigma, int df, int N, int qm, double alpha, double mu); void s_res_ewma_arl ( double *alpha, int *n, int *ctyp, double *l, double *cu, double *hs, double *sigma, double *mu, int *r, int *qm, double *arl) { *arl = -1.; *arl = seU_iglarl_RES(*l,*cu,*hs,*sigma,*n,*r,*qm,*alpha,*mu); } spc/src/xgrsr_crit.c0000644000175100001440000000057212655133155014210 0ustar hornikusers#include #include #include #include #define grsr1 0 #define grsr2 1 extern double rho0; double xsr1_crit(double k, double L0, double zr, double hs, double m0, int N, int MPT); void xgrsr_crit(double *k, double *L0, double *zr, double *hs, double *mu0, int *r, int *MPT, double *h) { *h = xsr1_crit(*k, *L0, *zr, *hs, *mu0, *r, *MPT); } spc/src/xcusum_sf.c0000644000175100001440000000106612655133155014035 0ustar hornikusers#include #include #include #include #define cusum1 0 #define cusum2 1 double *vector (long n); double xc1_sf(double k, double h, double hs, double mu, int N, int nmax, double *p0); void xcusum_sf(int *ctyp, double *k, double *h, double *hs, double *mu, int *r, int *n, double *sf) { int result=0, i; double *p0; p0 = vector(*n); if (*ctyp==cusum1) result = xc1_sf(*k, *h, *hs, *mu, *r, *n, p0); if ( result != 0 ) warning("trouble with xc1_sf called from xcusum_sf [package spc]"); for (i=0; i<*n; i++) sf[i] = p0[i]; } spc/src/sewma_arl.c0000644000175100001440000000332212655133155013770 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 double seU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm); double se2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double seUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double seLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double stdeU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm); double stde2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double stdeUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double stdeLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); void sewma_arl ( int *ctyp, double *l, double *cl, double *cu, double *hs, double *sigma, int *df, int *r, int *qm, int *s_squared, double *arl) { *arl = -1.; if ( *s_squared==1 ) { if ( *ctyp==ewmaU ) *arl = seU_iglarl(*l,*cu,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewma2 ) *arl = se2_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewmaUR ) *arl = seUR_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewmaLR ) *arl = seLR_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm); } else { if ( *ctyp==ewmaU ) *arl = stdeU_iglarl(*l,*cu,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewma2 ) *arl = stde2_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewmaUR ) *arl = stdeUR_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewmaLR ) *arl = stdeLR_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm); } } spc/src/quadrature_nodes_weights.c0000644000175100001440000000130612655133155017115 0ustar hornikusers#include #include #include #include #define GL 0 #define Ra 1 double *vector (long n); void gausslegendre(int n, double x1, double x2, double *x, double *w); void radau(int n, double x1, double x2, double *x, double *w); void quadrature_nodes_weights(int *n, double *x1, double *x2, int *type, double *nodes_weights) { double *knoten, *gewichte; int i; knoten = vector(*n); gewichte = vector(*n); if ( *type==GL ) gausslegendre(*n, *x1, *x2, knoten, gewichte); if ( *type==Ra ) radau(*n, *x1, *x2, knoten, gewichte); for (i=0; i<*n; i++) { nodes_weights[i] = knoten[i]; nodes_weights[i+*n] = gewichte[i]; } Free(gewichte); Free(knoten); } spc/src/xtewma_arl.c0000644000175100001440000000226712655133155014170 0ustar hornikusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 extern double rho0; double *vector (long n); double xte2_iglarl(double l, double c, double hs, int df, double mu, int N, int subst); double xte2_arlm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst); double xte2_arlm_hom(double l, double c, double hs, int df, int q, double mu0, double mu1, int N, double *ced, int subst); void xtewma_arl(int *ctyp, double *l, double *c, double *zr, double *hs, int *df, double *mu, int *ltyp, int *r, int *ntyp, int *q, double *arl) { int nmax=100000, i, result=0; double *ced, arl1=-1.; ced = vector(*q); if (*ctyp==ewma2 && *ltyp==fix && *q==1) arl1 = xte2_iglarl(*l,*c,*hs,*df,*mu,*r,*ntyp); if (*ctyp==ewma2 && *ltyp==fix && *q>1) result = xte2_arlm_hom(*l,*c,*hs,*df,*q,0.,*mu,*r,ced,*ntyp); if (*ctyp==ewma2 && *ltyp>fix ) arl1 = xte2_arlm(*l,*c,*hs,*df,*q,0.,*mu,*ltyp,*r,nmax,*ntyp); if ( result != 0 ) warning("trouble in xtewma_arl [package spc]"); if ( *ltyp==fix && *q>1 ) for (i=0; i<*q; i++) arl[i] = ced[i]; else *arl = arl1; } spc/src/xewma_sf.c0000644000175100001440000000307712655133155013636 0ustar hornikusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define stat 5 #define test 6 double *vector (long n); double xe1_sf (double l, double c, double zr, double hs, double mu, int N, int nmax, double *p0); double xe1_sfm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0); double xe2_sf (double l, double c, double hs, double mu, int N, int nmax, double *p0); double xe2_sfm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0); void xewma_sf(int *ctyp, double *l, double *c, double *zr, double *hs, double *mu, int *ltyp, int *r, int *q, int *n, double *sf) { int result=0, i; double *p0; p0 = vector(*n); if ( *ctyp==ewma1 && *ltyp==fix && *q==1 ) result = xe1_sf (*l, *c, *zr, *hs, *mu, *r, *n, p0); if ( *ctyp==ewma1 && *ltyp==fix && *q>1 ) result = xe1_sfm(*l, *c, *zr, *hs, *q, 0., *mu, *ltyp, *r, *n, p0); if ( *ctyp==ewma1 && *ltyp>fix ) result = xe1_sfm(*l, *c, *zr, *hs, *q, 0., *mu, *ltyp, *r, *n, p0); if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) result = xe2_sf (*l, *c, *hs, *mu, *r, *n, p0); if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) result = xe2_sfm(*l, *c, *hs, *q, 0., *mu, *ltyp, *r, *n, p0); if ( *ctyp==ewma2 && *ltyp>fix ) result = xe2_sfm(*l, *c, *hs, *q, 0., *mu, *ltyp, *r, *n, p0); if ( result != 0 ) warning("trouble in xewma_sf [package spc]"); for (i=0; i<*n; i++) sf[i] = p0[i]; } spc/src/xgrsr_ad.c0000644000175100001440000000063412655133155013632 0ustar hornikusers#include #include #include #include #define grsr1 0 #define grsr2 1 extern double rho0; double xsr1_iglad(double k, double h, double zr, double mu0, double mu1, int N, int MPT); void xgrsr_ad(int *ctyp, double *k, double *h, double *mu0, double *mu1, double *zr, int *r, int *MPT, double *ad) { if (*ctyp==grsr1) *ad = xsr1_iglad(*k, *h, *zr, *mu0, *mu1, *r, *MPT); } spc/src/allspc.c0000644000175100001440000211063112655133155013300 0ustar hornikusers#include #include #include #include #include #define LOG 0 #define TAIL 1 #define cusum1 0 #define cusum2 1 #define cusumC 2 #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define stat 5 #define fink 6 #define FINALeps 1e-12 #define lmEPS 1e-4 #define IDENTITY 0 #define SIN 1 #define SINH 2 #define TAN 3 /*** export ***/ /* CUSUM */ double xc_crit(int ctyp, double k, double L0, double hs, double m0, int N); /* one-sided CUSUM */ double xc1_iglarl(double k, double h, double hs, double mu, int N); double xc1_iglad (double k, double h, double mu0, double mu1, int N); double xc1_iglarl_drift(double k, double h, double hs, double delta, int m, int N, int with0); double xc1_iglarl_drift_wo_m(double k, double h, double hs, double delta, int *m, int N, int with0); double xc1_iglarlm_drift(double k, double h, double hs, int q, double delta, int N, int nmax, int with0); double xtc1_iglarl(double k, double h, double hs, int df, double mu, int N, int subst); double xc1_Wq(double k, double h, double p, double hs, double mu, int N, int nmax); double xc1_sf(double k, double h, double hs, double mu, int N, int nmax, double *p0); double xc1_arlm(double k, double h, double hs, int q, double mu0, double mu1, int N, int nmax); double xc1_arlm_hom(double k, double h, double hs, int q, double mu0, double mu1, int N, double *ced); /* classical two-sided (2 charts) CUSUM */ double xc2_iglarl(double k, double h, double hs, double mu, int N); double xc2_be_arl(double k, double h, double hs1, double hs2, double mu, int N); double xc2_iglad (double k, double h, double mu0, double mu1, int N); double xc2_iglarl_drift(double k, double h, double hs, double delta, int m, int N, int drift0); /* it is not accurate */ double xc2_iglarl_drift_wo_m(double k, double h, double hs, double delta, int *m, int N, int drift0); /* it is not accurate */ double xtc2_iglarl(double k, double h, double hs, int df, double mu, int N, int subst); /* Crosier's two-sided CUSUM */ double xcC_iglarl(double k, double h, double hs, double mu, int N); double xcC_iglad (double k, double h, double mu0, double mu1, int N); /* variance charts */ double scU_iglarl_v1(double refk, double h, double hs, double sigma, int df, int N, int qm); double scU_iglarl_v2(double refk, double h, double hs, double sigma, int df, int N, int qm); double scL_iglarl_v2(double refk, double h, double hs, double sigma, int df, int N, int qm); double sc2_iglarl_v2(double refkl, double refku, double hl, double hu, double hsl, double hsu, double sigma, int df, int N, int qm); double scU_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm); double scL_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm); double scU_fl_crit(double refkl, double refku, double hl, double L0, double hsl, double hsu, double sigma, int df, int N, int qm); double scL_fu_crit(double refkl, double refku, double hu, double L0, double hsl, double hsu, double sigma, int df, int N, int qm); int sc2_crit_unbiased(double refkl, double refku, double L0, double *hl, double *hu, double hsl, double hsu, double sigma, int df, int N, int qm); /*double sc2_eqtails(double refkl, double refku, double L0, double *hl, double *hu, double hsl, double hsu, double sigma, int df, int N, int qm);*/ /* Shiryaev-Roberts (only the one-sided version is implemented) */ double xsr1_crit(double k, double L0, double zr, double hs, double m0, int N, int MPT); double xsr1_iglarl(double k, double h, double zr, double hs, double mu, int N, int MPT); double xsr1_iglad(double k, double h, double zr, double mu0, double mu1, int N, int MPT); double xsr1_arlm(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int nmax, int MPT); double xsr1_arlm_hom(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int MPT, double *ced); double xsr1_iglarl_drift(double k, double h, double zr, double hs, double delta, int m, int N, int with0); double xsr1_iglarl_drift_wo_m(double k, double h, double zr, double hs, double delta, int *m, int N, int with0); double xsr1_iglarlm_drift(double k, double h, double zr, double hs, int q, double delta, int N, int nmax, int with0); /* EWMA */ double xe_crit(int ctyp, double l, double L0, double zr, double hs, double m0, int ltyp, int N, double c0); double xe_q_crit(int ctyp, double l, int L0, double alpha, double zr, double hs, double m0, int ltyp, int N, double c_error, double a_error); /* one-sided EWMA */ double xe1_iglarl(double l, double c, double zr, double hs, double mu, int N); double xe1_iglad (double l, double c, double zr, double mu0, double mu1, int N); double xe1_arlm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); double xe1_arlm_hom(double l, double c, double zr, double hs, int q, double mu0, double mu1, int N, double *ced); double xe1_Warl(double l, double c, double zr, double hs, double mu, int N, int nmax); double xe1_Wq(double l, double c, double p, double zr, double hs, double mu, int N, int nmax); double xe1_sf(double l, double c, double zr, double hs, double mu, int N, int nmax, double *p0); double xe1_sfm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0); double xe1_Wqm(double l, double c, double p, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); double xe1_iglarl_drift(double l, double c, double zr, double hs, double delta, int m, int N, int with0); double xe1_iglarl_drift_wo_m(double l, double c, double zr, double hs, double delta, int *m, int N, int with0); double xe1_iglarlm_drift(double l, double c, double zr, double hs, int q, double delta, int N, int nmax, int with0); double xlimit1_arlm(double c, double zr, int q, double mu0, double mu1, int N, int nmax); /* two-sided EWMA */ double xe2_iglarl(double l, double c, double hs, double mu, int N); double xe2_iglad (double l, double c, double mu0, double mu1, int N); double xe2_igladc(double l, double c, double mu0, double mu1, double z0, int N); double xe2_arlm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); int xe2_arlm_special(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *pair); double xe2_arlm_hom(double l, double c, double hs, int q, double mu0, double mu1, int N, double *ced); double xe2_Wq(double l, double c, double p, double hs, double mu, int N, int nmax); double xe2_sf(double l, double c, double hs, double mu, int N, int nmax, double *p0); double xe2_sfm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0); double xe2_Wqm(double l, double c, double p, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); double xe2_Warl(double l, double c, double hs, double mu, int N, int nmax); /* Waldmann's ARL procedure */ double xe2_Carl(double l, double c, double hs, double mu, int N, int qm); /* collocation */ double xe2_iglarl_drift(double l, double c, double hs, double delta, int m, int N, int with0); double xe2_iglarl_drift_wo_m(double l, double c, double hs, double delta, int *m, int N, int with0); double xe2_iglarlm_drift(double l, double c, double hs, int q, double delta, int N, int nmax, int with0); double xe2_Warl_drift(double l, double c, double hs, double delta, int N, int nmax, int with0); /* functions based on Srivastava & Wu (1997) */ double xe2_SrWu_crit(double l, double L0); double xe2_SrWu_arl(double l, double c, double mu); double xe2_SrWu_arl_full(double l, double c, double mu); double xe2_SrWu_lambda(double delta, double L0); /* t distribution */ double xte2_iglarl(double l, double c, double hs, int df, double mu, int N, int subst); double xte2_iglad (double l, double c, int df, double mu0, double mu1, int N, int subst); double xte2_igladc(double l, double c, int df, double mu0, double mu1, double z0, int N, int subst); double xte2_arlm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst); double xte2_arlm_hom(double l, double c, double hs, int df, int q, double mu0, double mu1, int N, double *ced, int subst); double xte2_Wq(double l, double c, double p, double hs, int df, double mu, int N, int nmax, int subst); double xte2_sf(double l, double c, double hs, int df, double mu, int N, int nmax, double *p0, int subst); double xte2_sfm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0, int subst); double xte2_Wqm(double l, double c, double p, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst); /* incorporate pre-run uncertainty */ double xe2_iglarl_prerun_MU(double l, double c, double hs, double mu, int pn, int qm, double truncate); double xe2_iglarl_prerun_SIGMA(double l, double c, double hs, double mu, int pn, int qm, double truncate); double xe2_iglarl_prerun_BOTH(double l, double c, double hs, double mu, int pn, int df, int qm1, int qm2, double truncate); double xe2_arlm_prerun_MU(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate); double xe2_arlm_prerun_SIGMA(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate); double xe2_arlm_prerun_BOTH(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate); double xe2_sf_deluxe(double l, double c, double hs, double mu, int N, int nmax, double BOUND, double *p0, int *nstop, double *rho); double xe2_sf_prerun_MU_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sf_prerun_MU(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double *p0); double xe2_sf_prerun_SIGMA_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sf_prerun_SIGMA(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double *p0); double xe2_sf_prerun_BOTH_deluxe(double l, double c, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double BOUND, double *p0); double xe2_sf_prerun_BOTH(double l, double c, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double *p0); double xe2_sfm_simple(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0); double xe2_sfm_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double BOUND, double *p0, int *nstop, double *rho); double xe2_sfm_prerun_MU_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sfm_prerun_MU(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double *p0); double xe2_sfm_prerun_SIGMA_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sfm_prerun_SIGMA(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double *p0); double xe2_sfm_prerun_BOTH_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double BOUND, double *p0); double xe2_sfm_prerun_BOTH(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double *p0); double xe2_Wq_prerun_MU_deluxe(double l, double c, double p, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND); double xe2_Wq_prerun_SIGMA_deluxe(double l, double c, double p, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND); double xe2_Wq_prerun_BOTH_deluxe(double l, double c, double p, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double BOUND); double xe2_Wqm_prerun_MU_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND); double xe2_Wqm_prerun_SIGMA_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND); double xe2_Wqm_prerun_BOTH_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double BOUND); /* EWMA residual charts */ double xe2_iglarl_RES(double l, double c, double hs, double mu, int N, double alpha, int df); double seU_iglarl_RES(double l, double cu, double hs, double sigma, int df, int N, int qm, double alpha, double mu); double xseU_arl_RES(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double alpha); double xseU_mu_before_sigma_RES(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double alpha, int vice_versa); /* Shewhart charts for dependent data */ double x_shewhart_ar1_arl(double alpha, double cS, double mu, int N1, int N2); /* variance charts */ double seU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm); double se2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double seUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double seLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double stdeU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm); double stde2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double stdeUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double stdeLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double lns2ewmaU_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N); double lns2ewma2_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N); double seU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm); double se2lu_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm); double se2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); int se2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm); int se2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm); double se2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm); double seUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm); double seLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); double stdeU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm); double stde2lu_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm); double stde2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); int stde2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm); int stde2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm); double stde2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm); double stdeUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm); double stdeLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); double lns2ewmaU_crit(double l, double L0, double cl, double hs, double sigma, int df, int N); double lns2ewma2_crit_cufix(double l, double cu, double L0, double hs, double sigma, int df, int N); double lns2ewma2_crit_sym(double l, double L0, double hs, double sigma, int df, int N); int lns2ewma2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N); double seU_sf(double l, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); double seU_sf_deluxe(double l, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho); double se2_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); double se2_sf_deluxe(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho); double seUR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); double seUR_sf_deluxe(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho); double seLR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); double seLR_sf_deluxe(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho); double seU_q_crit(double l, int L0, double alpha, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); double se2lu_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); double se2fu_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); int se2_q_crit(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); int se2_q_crit_class(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm, double c_error, double a_error); double seUR_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); double seLR_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); double seU_Wq(double l, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); double se2_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); double seUR_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); double seLR_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); /* MEWMA: Rigdon (1995a,b) */ double mxewma_arl_0a(double lambda, double ce, int p, double hs, int N); /* GL class */ double mxewma_arl_0a2(double lambda, double ce, int p, double hs, int N); /* GL mod */ double mxewma_arl_0b(double lambda, double ce, int p, double hs, int N, int qm); /* collocation */ double mxewma_arl_0c(double lambda, double ce, int p, double hs, int N); /* Radau (Rigdon) */ double mxewma_arl_0d(double lambda, double ce, int p, double hs, int N); /* Clenshaw-Curtis */ double mxewma_arl_0e(double lambda, double ce, int p, double hs, int N); /* Markov chain (Runger/Prabhu) */ double mxewma_arl_0f(double lambda, double ce, int p, double hs, int N); /* Simpson rule (poor performance) */ double mxewma_arl_f_0a(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0a2(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0b(double lambda, double ce, int p, int N, int qm, double *ARL); double mxewma_arl_f_0c(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0d(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0e(double lambda, double ce, int p, int N, double *ARL, double *z); double mxewma_arl_f_0f(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_1a (double lambda, double ce, int p, double delta, double hs, int N); /* GL class */ double mxewma_arl_1a2(double lambda, double ce, int p, double delta, double hs, int N); /* GL mod */ double mxewma_arl_1a3(double lambda, double ce, int p, double delta, double hs, int N); /* GL again mod sin, default for 2 and 4 */ double mxewma_arl_1a4(double lambda, double ce, int p, double delta, double hs, int N); /* GL again mod tan */ double mxewma_arl_1a5(double lambda, double ce, int p, double delta, double hs, int N); /* GL again mod sinh, default for all other p */ double mxewma_arl_f_1a (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL class */ double mxewma_arl_f_1a2(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL mod */ double mxewma_arl_f_1a3(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod sin, default for 2 and 4 */ double mxewma_arl_f_1a4(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod tan */ double mxewma_arl_f_1a5(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod sinh, default for all other p */ double mxewma_arl_1b(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); /* collocation */ double mxewma_arl_1b2(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); /* collocation, trimmed support of outer integral */ double mxewma_arl_1b3(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); /* collocation, tan instead of sin */ double mxewma_arl_1b4(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); /* collocation, sinh instead of sin */ double mxewma_arl_1c(double lambda, double ce, int p, double delta, double hs, int N); /* Radau (Rigdon) */ double mxewma_arl_1d(double lambda, double ce, int p, double delta, double hs, int N); /* Clenshaw-Curtis */ double mxewma_arl_1e(double lambda, double ce, int p, double delta, double hs, int N); /* Markov chain (Runger/Prabhu) */ double mxewma_arl_1f(double lambda, double ce, int p, double delta, double hs, int N); /* Simpson rule (poor performance) */ double mxewma_arl_f_1b (double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step + sin() */ double mxewma_arl_f_1b3(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step */ double mxewma_arl_f_1b2(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with shrinked supports of the outer integral */ double mxewma_arl_f_1b4(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step + sinh() instead of sin() */ double mxewma_arl_f_1c (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL + Radau (Rigdon) */ double mxewma_arl_f_1d (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* Clenshaw-Curtis */ double mxewma_arl_f_1e (double lambda, double ce, int p, double delta, int N, double *g, int *dQ); /* Markov Chain (Runger/Prabhu) */ double mxewma_arl_f_1f (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z); /* Simpson rule */ double mxewma_crit(double lambda, double L0, int p, double hs, int N); double mxewma_psi (double lambda, double ce, int p, int N, double *PSI, double *w, double *z); double mxewma_psiS(double lambda, double ce, int p, double hs, int N, double *PSI, double *w, double *z); double mxewma_ad (double lambda, double ce, int p, double delta, int N, int qm2, int psi_type, double hs, int qtype, int qm0, int qm1); /* incorporate pre-run uncertainty */ double seU_sf_prerun_SIGMA_deluxe(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seU_sf_prerun_SIGMA(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seUR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seUR_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double se2_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double se2_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seLR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seLR_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seU_iglarl_prerun_SIGMA(double l, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seUR_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double se2_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seLR_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seU_q_crit_prerun_SIGMA(double l, int L0, double alpha, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double se2lu_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double se2fu_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); int se2_q_crit_prerun_SIGMA(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double seUR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double seLR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double seU_Wq_prerun_SIGMA_deluxe(double l, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); double seUR_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); double seLR_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); double se2_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); double seU_crit_prerun_SIGMA(double l, double L0, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double se2lu_crit_prerun_SIGMA(double l, double L0, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double se2fu_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); int se2_crit_prerun_SIGMA(double l, double L0, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seUR_crit_prerun_SIGMA(double l, double L0, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seLR_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); /* simultaneous EWMA charts */ double xseU_arl(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); double xse2_arl(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); int xseU_crit(double lx, double ls, double L0, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); int xse2lu_crit(double lx, double ls, double L0, double *cx, double csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); int xse2fu_crit(double lx, double ls, double L0, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); int xse2_crit(double lx, double ls, double L0, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); double xseU_sf(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0); double xseU_sf_deluxe(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0, int *nstop, double *rho); double xse2_sf(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0); double xse2_sf_deluxe(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0, int *nstop, double *rho); int xseU_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error); int xse2fu_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error); int xse2_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error); double xseU_Wq(double lx, double ls, double cx, double cs, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); double xse2_Wq(double lx, double ls, double cx, double csl, double csu, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); /* EWMA p under sampling by variables */ double WK_h(double mu, double sigma, double LSL, double USL); double wk_h_mu(double mu, double sigma, double LSL, double USL); double wk_h_sigma(double mu, double sigma, double LSL, double USL); double WK_h_invers_mu(double p, double sigma, double LSL, double USL); double WK_h_invers_sigma(double p, double mu, double LSL, double USL); double wk_alpha(double p, double sigma, int n, double LSL, double USL); double cdf_phat(double p, double mu, double sigma, int n, double LSL, double USL); double pdf_phat(double p, double mu, double sigma, int n, double LSL, double USL); double qf_phat(double p0, double mu, double sigma, int n, double LSL, double USL); double wk_cdf_i(double y, double p, double mu, double sigma, int n, double LSL, double USL); double wk_pdf_i(double y, double p, double mu, double sigma, int n, double LSL, double USL); double cdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes); double pdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes); double qf_phat2(double p0, double mu, double sigma, int n, double LSL, double USL, int nodes); double ewma_phat_arl (double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm); double ewma_phat_arl_be(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N); double ewma_phat_crit(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm); double ewma_phat_lambda(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm); double ewma_phat_arl2 (double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M); double ewma_phat_arl2_be(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N); double ewma_phat_crit2(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M); double ewma_phat_lambda2(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm, int M); /* attribute EWMA p (X follows binomial distribution) */ double ewma_p_arl(double lambda, double ucl, int n, double p, double z0, int d_res, int round_mode, int mid_mode); /* tolerance intervals */ double kww(int n, double q, double a); double tl_factor(int n, double q, double a, int m); /* internal functions etc. */ int qm_for_l_and_c(double l, double c); int choose_N_for_seU(double lambda); int choose_N_for_se2(double lambda, double cl, double cu); void gausslegendre(int n, double x1, double x2, double *x, double *w); void radau(int n, double x1, double x2, double *x, double *w); int LU_decompose(double *a, int *ps, int n); void LU_solve(double *a, double *b, int n); void LU_solve2(double *a, double *b, int *ps, int n); void pmethod(int n, double *p, int *status, double *lambda, double x_[], int *noofit); int *ivector(long n); double *vector (long n); double *matrix(long m, long n); double phi(double x, double mu); double PHI(double x, double mu); double qPHI(double p); double chi(double s, int df); double CHI(double s, int df); double qCHI(double p, int df); double nchi(double s, int df, double ncp); double nCHI(double s, int df, double ncp); double nqCHI(double p, int df, double ncp); double pdf_t(double x, int df); double cdf_t(double x, int df); double qf_t(double x, int df); double pdf_tn(double x, int df, double ncp); double cdf_tn(double x, int df, double ncp); double qf_tn(double x, int df, double ncp); double cdf_binom(double q, int n, double p); double pdf_binom(double x, int n, double p); double Tn(double z, int n); /* Chebyshev polynomials */ double iTn(double z, int n); /* indefinite integrals of Chebyshev polynomials */ double dTn(double z, int n); /* derivatives of Chebyshev polynomials */ double rho0; /* ------------------- functions and procedures ------------- */ int *ivector(long n) { return (int *) Calloc( n, int ); } double *vector(long n) { return (double *) Calloc( n, double ); } double *matrix(long m, long n) { return (double *) Calloc( m*n, double ); } /* normal density (pdf) */ double phi(double x, double mu) { return dnorm(x,mu,1.,LOG); } /* normal cumulative distribution function (cdf) */ double PHI(double x, double mu) { return pnorm(x,mu,1.,TAIL,LOG); } /* qf of normal rv */ double qPHI(double p) { return qnorm(p,0.,1.,TAIL,LOG); } /* pdf of chisquare rv */ double chi(double s, int df) { return dchisq(s,(double)df,LOG); } /* pdf of non-central chisquare rv */ double nchi(double s, int df, double ncp) { return dnchisq(s,(double)df,ncp,LOG); } /* cdf of chisquare rv */ double CHI(double s, int df) { return pchisq(s,(double)df,TAIL,LOG); } /* cdf of non-central chisquare rv */ double nCHI(double s, int df, double ncp) { return pnchisq(s,(double)df,ncp,TAIL,LOG); } /* qf of chisquare rv */ double qCHI(double p, int df) { return qchisq(p,(double)df,TAIL,LOG); } /* qf of non-central chisquare rv */ double nqCHI(double p, int df, double ncp) { return qnchisq(p,(double)df,ncp,TAIL,LOG); } /* pdf of t distribution */ double pdf_t(double x, int df) { return dt(x,(double)df,LOG); } /* cdf of t distribution */ double cdf_t(double x, int df) { return pt(x,(double)df,TAIL,LOG); } /* quantile function of t distribution */ double qf_t(double x, int df) { return qt(x,(double)df,TAIL,LOG); } /* pdf of non-central t distribution */ double pdf_tn(double x, int df, double ncp) { return dnt(x,(double)df,ncp,LOG); } /* cdf of non-central t distribution */ double cdf_tn(double x, int df, double ncp) { return pnt(x,(double)df,ncp,TAIL,LOG); } /* quantile function of non-central t distribution */ double qf_tn(double x, int df, double ncp) { return qnt(x,(double)df,ncp,TAIL,LOG); } /* cdf of binomial rv */ double cdf_binom(double q, int n, double p) { return pbinom(q,(double)n,p,TAIL,LOG); } /* pdf of binomial rv */ double pdf_binom(double x, int n, double p) { return dbinom(x,(double)n,p,LOG); } /* expectation of log-gamma */ double E_log_gamma(double ddf) { return log(2./ddf) + digamma(ddf/2.); } /* variance of log-gamma */ double V_log_gamma(double ddf) { return trigamma(ddf/2.); } /* expectation of S (chi) */ double c_four(double ddf) { return sqrt( 2./ddf ) * gammafn( (ddf+1)/2. ) / gammafn( ddf/2. ); } /* abscissae and weights of Gauss-Legendre quadrature */ #define GLeps 3e-11 void gausslegendre(int n, double x1, double x2, double *x, double *w) /* The following algorithm is based on ideas of Knut Petras (see http://www-public.tu-bs.de:8080/~petras/). The nodes are derived by means of the Newton method. Afterwards, the weights are obtained by utilizing (regarding the connection between the Christoffel function and the weight, which is also called Christoffel number) w_i = w(x_i) = 2 / sum_j=0^n ( (2j+1) * (P_j(x_i))^2 ) which is more stable than to rely on the usual w_i = 2 / (1-x_i^2)/(P_n^'(x_i))^2. Note that the Newton method is stopped as soon as the distance between two successive iterates is smaller than GLeps, plus one extra step. By comparing with results in Yakimiw (1996) we may conclude that the code behaves very well and even better. */ { double xw, xmid, z0, z1, diff, p0, p1, p2=0., a; int i, j, m, stop, odd; m = (n+1)/2; odd = n%2 == 1; xmid = .5*(x2+x1); /* interval centre */ xw = .5*(x2-x1); /* half interval length */ for (i=0;i kind of overiterating) */ } x[i] = xmid + xw*z1; x[n-1-i] = xmid - xw*z1; /* nodes on interval (x1,x2) */ p0 = 1.; p1 = z1; a = 1. + 3.*z1*z1; for (j=1;jfabs(newmu) ) { newmu = y_[i]; newi = i; } for (i=0;i 1e-10 ) arl = ( exp(-2.*Delta*b) + 2.*Delta*b - 1. )/2./Delta/Delta; else arl = b*b; return arl; } double BM_xc_crit(double k, double L0, double m0) { double c1, c2, c3, L1=0., L2=0., L3=0., dc; c2 = 0.; do { c2 += .1; L2 = BM_xc_arl(k, c2, m0); } while ( L2 1e-10 ) { c3 = c1 + (L0-L1)/(L2-L1) * (c2-c1); L3 = BM_xc_arl(k, c3, m0); dc = c3-c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3; } else { dc = 1e-12; c3 = c2; } } while ( (fabs(L0-L3)>1e-6) && (fabs(dc)>1e-9) ); return c3; } /* ************************************************************************* */ /* zero-state and steady-state ARl and critical value routines */ double xc_crit(int ctyp, double k, double L0, double hs, double m0, int N) { double c1, c2, c3, L1=0., L2=0., L3=0., dc, k_bm; if ( ctyp==cusumC || fabs(hs)>1e-9 ) { c2 = 0.; do { c2 += .5; if (ctyp==cusum1) L2 = xc1_iglarl ( k,c2,hs,m0,N ); if (ctyp==cusum2) L2 = xc2_iglarl ( k,c2,hs,m0,N ); if (ctyp==cusumC) L2 = xcC_iglarl ( k,c2,hs,m0,N ); } while (L21e-6) && (fabs(dc)>1e-9) ); return c3; } double xsr1_crit(double k, double L0, double zr, double hs, double m0, int N, int MPT) { double c1, c2, c3, L1, L2, L3, dc; c2 = 0.; do { c2 += .5; L2 = xsr1_iglarl(k, c2, zr, hs, m0, N, MPT); } while ( L21e-6) && (fabs(dc)>1e-9) ); return c3; } double xe_crit(int ctyp, double l, double L0, double zr, double hs, double m0, int ltyp, int N, double c0) { double c1, c2, c3, L1=0., L2=0., L3=0., dc, norm, L2old=0., c2old=0.; int nmax=100000; if ( (ctyp==ewma1 && c0 < zr) || (ctyp==ewma2 && c0 < 0.) ) c2 = 1.; else c2 = c0; do { if ( ctyp==ewma1 ) { if ( ltyp==fix && hs>=0. ) L2 = xe1_iglarl ( l,c2,zr,hs,m0,N ); if ( ltyp==fix && hs<0. ) L2 = xe1_iglarl ( l,c2,zr,c2/2,m0,N ); if ( ltyp>fix ) L2 = xe1_arlm ( l,c2,zr,hs,1,m0,m0,ltyp,N,nmax ); } if ( ctyp==ewma2 ) { if ( ltyp==fix ) L2 = xe2_iglarl ( l,c2,hs,m0,N ); if ( ltyp>fix ) { if ( hs<0. && ltyp==fir ) L2 = xe2_arlm ( l,c2,c2/2.,1,m0,m0,ltyp,N,nmax ); if ( hs<0. && ltyp==both ) L2 = xe2_arlm ( l,c2,c2/2.*sqrt(l*(2.-l)),1,m0,m0,ltyp,N,nmax ); if ( hs>=0. ) L2 = xe2_arlm ( l,c2,hs,1,m0,m0,ltyp,N,nmax ); } } if ( L2 < 1. ) c2 -= .1; } while ( L2 < 1. && c2 > .00001 ); if ( L2 < 1. ) error("invalid ARL value"); if ( L2 > L0 ) { norm = -.1; } else { norm = .5; } if ( L2 < 1. + 1e-12 ) { c2 = 0.; norm = .1; } if ( (ctyp==ewma1 && c0 > zr) || (ctyp==ewma2 && c0 > 0.) ) norm /= 10.; do { L2old = L2; c2old = c2; c2 += norm; do { if ( ctyp==ewma1 ) { if ( ltyp==fix && hs>=0. ) L2 = xe1_iglarl ( l,c2,zr,hs,m0,N ); if ( ltyp==fix && hs<0. ) L2 = xe1_iglarl ( l,c2,zr,c2/2,m0,N ); if ( ltyp>fix ) L2 = xe1_arlm ( l,c2,zr,hs,1,m0,m0,ltyp,N,nmax ); } if ( ctyp==ewma2 ) { if ( ltyp==fix ) L2 = xe2_iglarl ( l,c2,hs,m0,N ); if ( ltyp>fix ) { if ( hs<0. && ltyp==fir ) L2 = xe2_arlm ( l,c2,c2/2.,1,m0,m0,ltyp,N,nmax ); if ( hs<0. && ltyp==both ) L2 = xe2_arlm ( l,c2,c2/2.*sqrt(l*(2.-l)),1,m0,m0,ltyp,N,nmax ); if ( hs>=0. ) L2 = xe2_arlm ( l,c2,hs,1,m0,m0,ltyp,N,nmax ); } } if ( L2 < 1. ) { norm /= 2.; c2 -= norm; } if ( c2 <= 1e-9 && fabs(L2-L2old)>100. ) norm = -.001; } while ( L2 < 1. ); } while ( ((L2 < L0 && norm>0.) || (L2 > L0 && norm<0.)) && (fabs(norm)>1e-8) ); c1 = c2old; L1 = L2old; do { c3 = c1 + (L0-L1)/(L2-L1) * (c2-c1); norm = .5; do { if ( ctyp==ewma1 ){ if ( ltyp==fix && hs>=0. ) L3 = xe1_iglarl ( l,c3,zr,hs,m0,N ); if ( ltyp==fix && hs<0. ) L3 = xe1_iglarl ( l,c3,zr,c3/2,m0,N ); if ( ltyp>fix ) L3 = xe1_arlm ( l,c3,zr,hs,1,m0,m0,ltyp,N,nmax ); } if ( ctyp==ewma2 ) { if ( ltyp==fix ) L3 = xe2_iglarl ( l,c3,hs,m0,N ); if ( ltyp>fix ) { if ( hs<0. && ltyp==fir ) L3 = xe2_arlm ( l,c3,c3/2.,1,m0,m0,ltyp,N,nmax ); if ( hs<0. && ltyp==both ) L3 = xe2_arlm ( l,c3,c3/2.*sqrt(l*(2.-l)),1,m0,m0,ltyp,N,nmax ); if ( hs>=0. ) L3 = xe2_arlm ( l,c3,hs,1,m0,m0,ltyp,N,nmax ); } } if ( L3 < 1. ) { c3 = c1 + norm*(L0-L1)/(L2-L1) * (c2-c1); norm /= 2.; } } while ( (L3 < 1.) && (fabs(norm)>1e-8) ); dc = c3-c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3; if ( L3 < 1. ) error("invalid ARL value"); } while ( (fabs(L0-L3)>1e-6) && (fabs(dc)>1e-9) ); if ( fabs(L0-L3)>1e-6 ) warning("did not converge"); return c3; } double xe_q_crit(int ctyp, double l, int L0, double alpha, double zr, double hs, double m0, int ltyp, int N, double c_error, double a_error) { double c1=0., c2=0., c3=0., p1=1., p2=1., p3=1., dc, *SF; int result=1; SF = vector(L0); c2 = 0.; p2 = 1.; do { p1 = p2; c2 += .5; if ( ctyp==ewma1 && ltyp==fix ) result = xe1_sf(l, c2, zr, hs, m0, N, L0, SF); if ( ctyp==ewma1 && ltyp>fix ) error("not implemented yet for one-sided EWMA and varying limits"); if ( ctyp==ewma2 && ltyp==fix ) result = xe2_sf(l, c2, hs, m0, N, L0, SF); if ( ctyp==ewma2 && ltyp>fix ) result = xe2_sfm(l, c2, hs, 1, m0, m0, ltyp, N, L0, SF); if ( result != 0 ) warning("trouble in xe_q_crit [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha ); c1 = c2 - .5; do { c3 = c1 + ( alpha - p1 )/( p2 - p1 ) * ( c2 - c1 ); if ( ctyp==ewma1 && ltyp==fix ) result = xe1_sf(l, c3, zr, hs, m0, N, L0, SF); if ( ctyp==ewma1 && ltyp>fix ) error("not implemented yet for one-sided EWMA and varying limits"); if ( ctyp==ewma2 && ltyp==fix ) result = xe2_sf(l, c3, hs, m0, N, L0, SF); if ( ctyp==ewma2 && ltyp>fix ) result = xe2_sfm(l, c3, hs, 1, m0, m0, ltyp, N, L0, SF); if ( result != 0 ) warning("trouble in xe_q_crit [package spc]"); p3 = 1. - SF[L0-1]; dc = c3 - c2; c1 = c2; p1 = p2; c2 = c3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(dc)>c_error ); Free(SF); return c3; } double xc1_iglarl (double k, double h, double hs, double mu, int N) { double *a, *g, *w, *z, arl; int i, j, NN; NN = N + 1; a = matrix(NN,NN); g = vector(NN); w = vector(N); z = vector(N); gausslegendre(N,0.,h,z,w); for (i=0;i1 ) { for (i=0; imn_plus ) mn_plus = ratio; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(p0); Free(Pn); Free(z); Free(w); Free(atom); return Wq; } double xc1_sf(double k, double h, double hs, double mu, int N, int nmax, double *p0) { double *Pn, *w, *z, *atom; int i, j, n; w = vector(N); z = vector(N); Pn = matrix(nmax,N); atom = vector(nmax); gausslegendre(N,0,h,z,w); for (n=1;n<=nmax;n++) { if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { /* determine f_n, n=q,q+1,... */ if (n==1) { for (i=0;i1) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI(k, mu1); for (j=0;j1) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2.; rho0 = rho; Free(w); Free(z); Free(fn); Free(p0); return arl; } double xc1_arlm_hom(double k, double h, double hs, int q, double mu0, double mu1, int N, double *ced) { double *fn, *w, *z, *a, *arl, norm; int i, j, n, NN; NN = N + 1; w = vector(NN); z = vector(NN); fn = matrix(q+1, NN); a = matrix(NN,NN); arl = vector(NN); gausslegendre(N, 0., h, z, w); /* ARL vector */ for (i=0; i 1 */ for (n=1; n<=q-1; n++) { if (n==1) { for (i=0; ieps && (double)m_<1e4 ) { m_ = (int)round(1.5 * m_); arl1 = xc1_iglarl_drift(k, h, hs, delta, m_, N, with0); arl2 = xc1_iglarl_drift(k, h, hs, delta, m_+1, N, with0); } *m = m_; return arl1; } double xc1_iglarlm_drift(double k, double h, double hs, int q, double delta, int N, int nmax, int with0) { double *p0, *fn, *w, *z, arl0, rho, MEAN=0., arl_minus=0., arl, arl_plus=0., mn_minus=0., mn_plus=0., nn, ratio=0.; int i, j, n, NN; NN = N + 1; w = vector(NN); z = vector(NN); fn = matrix(nmax, NN); p0 = vector(nmax); gausslegendre(N, 0, h, z, w); /* in-control, i. e. n<=q-1 */ MEAN = 0.; for (n=1;n<=q-1;n++) { nn = (double) n; /* determine f_n, n=1,2,...,q-1 */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine f_n, n=q,q+1,... */ if ( with0 ) { MEAN = (nn-(double)q) * delta; } else { MEAN = (nn-(double)q+1.) * delta; } if (n==1) { for (i=0;i1) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI(k, MEAN); for (j=0;j1) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2.; rho0 = rho; Free(w); Free(z); Free(fn); Free(p0); return arl; } double xc2_iglarl(double k, double h, double hs, double mu, int N) { double arl1, arl2, arl3, arl4, arl; /* relation between 1- and 2-sided CUSUM schemes due to Lucas/Crosier 1982, Technometrics 24, 199-205; only for headstart hs smaller than h/2 + k !! */ arl1 = xc1_iglarl(k,h,0.,mu,N); arl2 = xc1_iglarl(k,h,hs,mu,N); arl3 = xc1_iglarl(k,h,0.,-mu,N); arl4 = xc1_iglarl(k,h,hs,-mu,N); arl = ( arl2*arl3 + arl1*arl4 - arl1*arl3 ) / ( arl1 + arl3 ); return arl; } double xtc2_iglarl(double k, double h, double hs, int df, double mu, int N, int subst) { double arl1, arl2, arl3, arl4, arl; /* relation between 1- and 2-sided CUSUM schemes due to Lucas/Crosier 1982, Technometrics 24, 199-205; only for headstart hs smaller than h/2 + k !! */ arl1 = xtc1_iglarl(k, h, 0., df, mu, N, subst); arl2 = xtc1_iglarl(k, h, hs, df, mu, N, subst); arl3 = xtc1_iglarl(k, h, 0., df, -mu, N, subst); arl4 = xtc1_iglarl(k, h, hs, df, -mu, N, subst); arl = ( arl2*arl3 + arl1*arl4 - arl1*arl3 ) / ( arl1 + arl3 ); return arl; } double xc2_be_arl (double k, double h, double hs1, double hs2, double mu, int N) { double *a, *g, arl, z1, z2, z11, z12, z21, z22, w; int i1, i2, j1, j2, NN, N3; /* two-dimensional Markov chain approximation */ NN = N*N; N3 = NN*N; a = matrix(NN,NN); g = vector(NN); w = 2.*h/(2.*N - 1.); for (i1=0;i1 z2 ) a[i1*N3+j1*NN+i2*N+j2] = 0.; else a[i1*N3+j1*NN+i2*N+j2] = -PHI(z2, mu) + PHI(z1, mu); if ( i1==i2 && j1==j2 ) a[i1*N3+j1*NN+i2*N+j2]++; } for (j1=0;j1eps && (double)m_<1e4 ) { m_ = (int)round(1.5 * m_); arl1 = xc2_iglarl_drift(k, h, hs, delta, m_, N, drift0); arl2 = xc2_iglarl_drift(k, h, hs, delta, m_+1, N, drift0); } *m = m_; return arl1; } double xcC_iglarl (double k, double h, double hs, double mu, int N) { double *a, *g, *w, *z, arl; int i, j, NN; NN = 2*N + 1; a = matrix(NN,NN); g = vector(NN); w = vector(NN); z = vector(NN); gausslegendre(N,0.,h,z,w); for (i=0;ib[ii-1] ) xl = za; else xl = b[ii-1]; xu = b[ii]; if ( df!=2 && b[ii]>za ) { xl = sqrt(xl-za); xu = sqrt(xu-za); } for (jj=1; jj<=Ntilde; jj++) { qj = (ii-1)*Ntilde + jj-1; if ( b[ii]h ) t1 = h; for (j=1; j1 ) { ii = i-1; t0 = (double)(ii-1.)*refk; t1 = t0 + refk; if ( t1>h ) t1 = h; if ( t01e-10 ) x0 = sqrt(x0-za); else x0 = 0.; if ( t1-za>1e-10 ) x1 = sqrt(t1-za); else x1 = 0.; } else x1 = t1; for (jj=1; jj<=Ntilde; jj++) { qj = (ii-1)*Ntilde + jj-1; if ( j==1 ) a[qi*NN + qj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),jj-1); else { if ( fabs(x1-x0)>1e-12 ) { gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; k 1 */ for (ii=i; ii<=M; ii++) { t0 = (double)(ii-1.)*refk; t1 = t0 + refk; if ( t1>h ) t1 = h; if ( t01e-10 ) x0 = sqrt(x0-za); else x0 = 0.; if ( t1-za>1e-10 ) x1 = sqrt(t1-za); else x1 = 0.; } else x1 = t1; if ( i>1 && j==1 && ii==i ) { for (jj=1; jj<=Ntilde; jj++) { qj = (ii-1)*Ntilde + jj-1; a[qi*NN + qj] = Tn((2.*t[it]-t0-t1)/(t1-t0),jj-1); } /* jj = 1 .. Ntilde */ } /* i>1 && j==1 && ii==i */ if ( i>1 && j==1 && ii>i ) { for (jj=1; jj<=Ntilde; jj++) { qj = (ii-1)*Ntilde + jj-1; a[qi*NN + qj] = 0.; } /* jj = 1 .. Ntilde */ } /* i>1 && j==1 && ii>i */ if ( i==1 || j>1 ) { for (jj=1; jj<=Ntilde; jj++) { qj = (ii-1)*Ntilde + jj-1; gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; k1 */ } /* ii = i .. M */ if ( i==1 ) { t0 = 0.; t1 = refk; if ( t1>h ) t1 = h; for (jj=1; jj<=Ntilde; jj++) { dummy = -za/s2; if ( dummy>0. ) { if ( df==1 ) dummy = 2.*PHI( sqrt(dummy), 0. ) - 1.; if ( df==2 ) dummy = 1. - exp( -dummy ); if ( df>2 ) dummy = CHI( ddf*dummy, df); } else dummy = 0.; a[qi*NN + jj-1] -= dummy * Tn(-1.,jj-1); } /* jj = 1 .. Ntilde */ } /* i==1 */ } /* i = 1 .. M, j = 1 .. Ntilde */ for (j=0; jh ) t1 = h; if ( t0<=hs && hsM ) imax = M; for (ii=1; ii<=imax; ii++) { t0 = h - (double)(M-ii+1.)*refk; t1 = t0 + refk; if ( t0<0. ) t0 = 0.; if ( t11e-10 ) x0 = sqrt(za-x1); else x0 = 0.; if ( za-t0>1e-10 ) x1 = sqrt(za-t0); else x1 = 0.; } else x0 = t0; for (jj=1; jj<=Ntilde; jj++) { qj = (ii-1)*Ntilde + jj-1; if ( i>1 && j==1 ) { /* continuity condition */ if ( ii==i-1 ) a[qi*NN + qj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),jj-1); if ( ii==i ) a[qi*NN + qj] = Tn((2.*t[it]-t0-t1)/(t1-t0),jj-1); if ( iii) a[qi*NN + qj] = 0.; } else { gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; k1 && j==1) */ } /* jj = 1 .. Ntilde */ } /* ii = 1 .. imax <= M */ for (ii=i+2; ii<=M; ii++) for (jj=1; jj<=Ntilde; jj++) { qj = (ii-1)*N + jj-1; a[qi*NN + qj] = 0.; } if ( i==1 || j>1 ) { for ( jj=1; jj<=Ntilde; jj++) { /* ii = 1 -- atom */ dummy = za/s2; if ( df==1 ) dummy = 2.*( 1. - PHI( sqrt(dummy), 0. ) ); if ( df==2 ) dummy = exp( -dummy ); if ( df>2 ) dummy = 1. - CHI( ddf*dummy, df); a[qi*NN + jj-1] -= dummy * Tn(-1.,jj-1); } /* jj = 1 .. Ntilde */ } /* i==1 || j>1 */ } /* i = 1 .. M, j = 1 .. Ntilde */ for (j=0; j1e-6) && (fabs(dc)>1e-9) ); return c3; } double scL_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm) { double c1, c2, c3, L1=0., L2=0., L3=0., dc; c2 = 0.; L2 = 1.; do { c1 = c2; L1 = L2; c2 += 1; L2 = scL_iglarl_v2(refk, c2, hs, sigma, df, N, qm); } while ( L21e-6) && (fabs(dc)>1e-9) ); return c3; } double scL_fu_crit(double refkl, double refku, double hu, double L0, double hsl, double hsu, double sigma, int df, int N, int qm) { double c1, c2, c3, L1=0., L2=0., L3=0., dc; c2 = 0.; L2 = 1.; do { c1 = c2; L1 = L2; c2 += 1; L2 = sc2_iglarl_v2(refkl, refku, c2, hu, hsl, hsu, sigma, df, N, qm); } while ( L21e-6) && (fabs(dc)>1e-9) ); return c3; } double scU_fl_crit(double refkl, double refku, double hl, double L0, double hsl, double hsu, double sigma, int df, int N, int qm) { double c1, c2, c3, L1=0., L2=0., L3=0., dc; c2 = 0.; L2 = 1.; do { c1 = c2; L1 = L2; c2 += 1; L2 = sc2_iglarl_v2(refkl, refku, hl, c2, hsl, hsu, sigma, df, N, qm); } while ( L21e-6) && (fabs(dc)>1e-9) ); return c3; } int sc2_crit_unbiased(double refkl, double refku, double L0, double *hl, double *hu, double hsl, double hsu, double sigma, int df, int N, int qm) { double h1, h2, h3, dh, lh, sl1, sl2, sl3, Lm, Lp, step; step = .2/sqrt(df); h1 = scU_crit(refku, 2.*L0, hsu, sigma, df, N, qm); lh = scL_crit(refkl, 2.*L0, hsl, sigma, df, N, qm); Lm = sc2_iglarl_v2(refkl, refku, lh, h1, hsl, hsu, sigma-lmEPS, df, N, qm); Lp = sc2_iglarl_v2(refkl, refku, lh, h1, hsl, hsu, sigma+lmEPS, df, N, qm); sl1 = (Lp-Lm)/(2.*lmEPS); h2 = h1; sl2 = sl1; do { h1 = h2; sl1 = sl2; h2 = h1 + step; lh = scL_fu_crit(refkl, refku, h2, L0, hsl, hsu, sigma, df, N, qm); Lm = sc2_iglarl_v2(refkl, refku, lh, h2, hsl, hsu, sigma-lmEPS, df, N, qm); Lp = sc2_iglarl_v2(refkl, refku, lh, h2, hsl, hsu, sigma+lmEPS, df, N, qm); sl2 = (Lp-Lm)/(2.*lmEPS); } while ( sl2 < 0. ); do { h3 = h1 - sl1/(sl2-sl1) * (h2-h1); lh = scL_fu_crit(refkl, refku, h3, L0, hsl, hsu, sigma, df, N, qm); Lm = sc2_iglarl_v2(refkl, refku, lh, h3, hsl, hsu, sigma-lmEPS, df, N, qm); Lp = sc2_iglarl_v2(refkl, refku, lh, h3, hsl, hsu, sigma+lmEPS, df, N, qm); sl3 = (Lp-Lm)/(2.*lmEPS); dh = h3-h2; h1 = h2; sl1 = sl2; h2 = h3; sl2 = sl3; } while ( fabs(sl3)>1e-7 && fabs(dh)>1e-9 ); *hl = lh; *hu = h3; return 0; } /* MPT = Moustakides/Polunchenko/Tartakovsky */ double xsr1_iglarl(double k, double h, double zr, double hs, double mu, int N, int MPT) { double *a, *g, *w, *z, arl, adjust=1.; int i, j, NN; adjust = 1.; if ( MPT ) adjust = 2.*k; NN = N + 1; a = matrix(NN,NN); g = vector(NN); w = vector(NN); z = vector(NN); gausslegendre(N, zr, h, z, w); for (i=0;i h) { arl = 1. + PHI( zr/adjust + k, mu) * g[N]; for (j=0;j h ) { for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0; i=q */ arl0 = 1.; rho = 0.; for (n=q; n<=nmax; n++) { if ( n==1 ) { if ( hs > h ) { for (i=0; i1 ) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (zr-log(1.+exp(zr)))/adjust + k, mu1); for (j=0; j1 ) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i q ) { for (i=0; imn_plus ) mn_plus = ratio; } rho = p0[n-1]/p0[n-2]; } /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2.; rho0 = rho; Free(w); Free(z); Free(fn); Free(p0); return arl; } double xsr1_arlm_hom(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int MPT, double *ced) { double *fn, *w, *z, *a, *arl, adjust=1., norm; int i, j, n, NN; adjust = 1.; if ( MPT ) adjust = 2.*k; NN = N + 1; w = vector(NN); z = vector(NN); fn = matrix(q+1, NN); a = matrix(NN,NN); arl = vector(NN); gausslegendre(N, zr, h, z, w); /* ARL vector */ for (i=0; i h ) { ced[0] = 1. + PHI( zr/adjust + k, mu1) * arl[N]; for (j=0; j 1 */ for (n=1; n<=q-1; n++) { if ( n == 1 ) { if ( hs > h ) { for (i=0; i h) { arl = 1. + PHI( zr+k, MUs[0]) * ARLs[N]; for (j=0;jeps && (double)m_<1e4 ) { m_ = (int)round(1.5 * m_); arl1 = xsr1_iglarl_drift(k, h, zr, hs, delta, m_, N, with0); arl2 = xsr1_iglarl_drift(k, h, zr, hs, delta, m_+1, N, with0); } *m = m_; return arl1; } double xsr1_iglarlm_drift(double k, double h, double zr, double hs, int q, double delta, int N, int nmax, int with0) { double *p0, *fn, *w, *z, arl0, rho, MEAN=0., arl_minus=0., arl, arl_plus=0., mn_minus=0., mn_plus=0., nn, ratio=0.; int i, j, n, NN; NN = N + 1; w = vector(NN); z = vector(NN); fn = matrix(nmax, NN); p0 = vector(nmax); gausslegendre(N, zr, h, z, w); /* in-control, i. e. n<=q-1 */ MEAN = 0.; for (n=1;n<=q-1;n++) { nn = (double) n; /* determine f_n, n=1,2,...,q-1 */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine f_n, n=q,q+1,... */ if ( with0 ) { MEAN = (nn-(double)q) * delta; } else { MEAN = (nn-(double)q+1.) * delta; } if (n==1) { for (i=0;i1) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( zr-log(1.+exp(zr))+k, MEAN); for (j=0;j1) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2.; rho0 = rho; Free(w); Free(z); Free(fn); Free(p0); return arl; } double xsr1_iglad(double k, double h, double zr, double mu0, double mu1, int N, int MPT) { double *a, *w, *z, *arl, *psi, rho, ad, norm, adjust=1.; int i, j, status, noofit, NN; adjust = 1.; if ( MPT ) adjust = 2.*k; NN = N + 1; a = matrix(NN,NN); arl = vector(NN); psi = vector(NN); w = vector(NN); z = vector(NN); gausslegendre(N, zr, h, z, w); for (i=0; i 1. && fabs(mu) > 1. ) arl = PHI(w,0.)/phi(w,0.)/l/w; return arl; } double xe2_SrWu_arl_full(double l, double c, double mu) { double eta, Lmu, alpha1, alpha2, h1, h2, f1, f2, arl=-1., *w, *z; int i, qm=50; mu = fabs(mu); w = vector(qm); z = vector(qm); Lmu = c + 1.16*sqrt(l*mu); eta = mu * sqrt(2./l); gausslegendre(qm, 0, Lmu, z, w); alpha1 = 0.; alpha2 = 0.; for (i=0; ieps && (double)m_<1e4 ) { m_ = (int)round(1.5 * m_); arl1 = xe1_iglarl_drift(l, c, zr, hs, delta, m_, N, with0); arl2 = xe1_iglarl_drift(l, c, zr, hs, delta, m_+1, N, with0); } *m = m_; return arl1; } double xe1_iglarlm_drift(double l, double c, double zr, double hs, int q, double delta, int N, int nmax, int with0) { double *p0, *fn, *w, *z, arl0, rho, MEAN=0., arl_minus=0., arl, arl_plus=0., mn_minus=0., mn_plus=0., nn, ratio=0.; int i, j, n, NN; NN = N + 1; w = vector(NN); z = vector(NN); fn = matrix(nmax, NN); p0 = vector(nmax); c *= sqrt( l/(2.-l) ); zr *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); gausslegendre(N, zr, c, z, w); /* in-control, i. e. n<=q-1 */ MEAN = 0.; for (n=1;n<=q-1;n++) { nn = (double) n; /* determine f_n, n=1,2,...,q-1 */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine f_n, n=q,q+1,... */ if ( with0 ) { MEAN = (nn-(double)q) * delta; } else { MEAN = (nn-(double)q+1.) * delta; } if (n==1) { for (i=0;i1) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( zr, MEAN); for (j=0;j1) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2.; rho0 = rho; Free(w); Free(z); Free(fn); Free(p0); return arl; } double xe2_iglarl_drift(double l, double c, double hs, double delta, int m, int N, int with0) { double *a, *g, *w, *z, arl, *MUs, *ARLs; int i, j, m_; a = matrix(N,N); g = vector(N); w = vector(N); z = vector(N); ARLs = vector(N); MUs = vector(m+1); c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); gausslegendre(N, -c, c, z, w); if ( with0 ) { for (i=0;i<=m;i++) MUs[i] = (double)i * delta; } else { for (i=0;i<=m;i++) MUs[i] = (double)(i+1.) * delta; } for (i=0;ieps && (double)m_<1e4 ) { m_ = (int)round(1.5 * m_); arl1 = xe2_iglarl_drift(l, c, hs, delta, m_, N, with0); arl2 = xe2_iglarl_drift(l, c, hs, delta, m_+1, N, with0); } *m = m_; return arl1; } double xe2_iglarlm_drift(double l, double c, double hs, int q, double delta, int N, int nmax, int with0) { double *p0, *fn, *w, *z, arl0, rho, MEAN=0., arl_minus=0., arl, arl_plus=0., mn_minus=0., mn_plus=0., nn, ratio=0.; int i, j, n; w = vector(N); z = vector(N); fn = matrix(nmax, N); p0 = vector(nmax); c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); gausslegendre(N, -c, c, z, w); /* in-control, i. e. n<=q-1 */ MEAN = 0.; for (n=1;n<=q-1;n++) { nn = (double) n; /* determine f_n, n=1,2,...,q-1 */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine f_n, n=q,q+1,... */ if ( with0 ) { MEAN = (nn-(double)q) * delta; } else { MEAN = (nn-(double)q+1.) * delta; } if (n==1) { for (i=0;i1) fn[(n-1)*N+i] /= p0[q-2]; } } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -2.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2.; rho0 = rho; Free(w); Free(z); Free(fn); Free(p0); return arl; } double xe2_Warl_drift(double l, double c, double hs, double delta, int N, int nmax, int with0) { double *Pn, *w, *z, *p0, MEAN, nn, ratio, arl_minus=0., arl0=1., arl_plus=0., mn_minus=1., mn_plus=0.; int i, j, n; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); w = vector(N); z = vector(N); Pn = matrix(nmax,N); p0 = vector(nmax); gausslegendre(N,-c,c,z,w); arl0 = 1.; for (n=1;n<=nmax;n++) { nn = (double)n; if ( with0 ) { MEAN = (nn-1.) * delta; } else { MEAN = nn * delta; } if (n==1) for (i=0;i1) { for (i=0;imn_plus ) mn_plus = ratio; } } if (0.1) { for (i=0;imn_plus ) mn_plus = ratio; } arl_minus = arl + p0[n-1]/(1.-mn_minus); arl_plus = arl + p0[n-1]/(1.-mn_plus); } arl += p0[n-1]; if ( fabs( (arl_plus-arl_minus)/arl_minus )1 ) { for (i=0; imn_plus ) mn_plus = ratio; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(p0); Free(Pn); Free(z); Free(w); Free(Sm); return Wq; } double xte2_Wq(double l, double c, double p, double hs, int df, double mu, int N, int nmax, int subst) { double *Sm, *Pn, *w, *z, *p0, ratio, q_minus=0., q_plus=0., mn_minus=1., mn_plus=0., enumerator=0., Wq=0., norm=1., arg=0., korr=1.; int i, j, n; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); Sm = matrix(N, N); w = vector(N); z = vector(N); Pn = matrix(nmax, N); p0 = vector(nmax); switch ( subst ) { case IDENTITY: gausslegendre(N, -c, c, z, w); norm = 1.; break; case SIN: gausslegendre(N, -PI/2., PI/2., z, w); norm = 1.; break; case SINH: gausslegendre(N, -1., 1., z, w); norm = sinh(1.); break; case TAN: gausslegendre(N, -PI/4., PI/4., z, w); norm = 1.; break; } c /= norm; for (i=0; i1 ) { for (i=0; imn_plus ) mn_plus = ratio; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(p0); Free(Pn); Free(z); Free(w); Free(Sm); return Wq; } double xe2_Wqm(double l, double c, double p, double hs, int q, double mu0, double mu1, int mode, int N, int nmax) { double *Smatrix, *p0, *fn, *w, *z, dn, rn, cn, rn0, cn0, delta=0., q_minus=2., q_plus=3., mn_minus, mn_plus, nn, fSt, aSt, ratio, enumerator=0., nq, Wq=0.; int i, j, n; fSt = 0.5; aSt = ( -2./log10(1.-fSt) - 1.)/19.; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); if ( mode==fir || mode==both ) delta = 2.*hs; Smatrix = matrix(N, N); w = vector(N); z = vector(N); fn = matrix(nmax, N); p0 = vector(nmax); gausslegendre(N, -c, c, z, w); rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.; /* in-control, i. e. n<=q-1 */ for (n=1; n<=q-1; n++) { nn = (double) n; /* determine c_n and r_n, n=1,2,...,q-1 */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=1,2,...,q-1 */ if ( n==1 ) { for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i=q */ for (n=q; n<=nmax; n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0; i1 ) fn[(n-1)*N+i] /= p0[q-2]; } } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i q ) { for (i=0; imn_plus ) mn_plus = ratio; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = nq + enumerator/log(mn_minus); q_plus = nq + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > q */ } /* p0[n-1] >= 1.-p */ } /* n=q; n<=nmax; n++ */ Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return Wq; } double xte2_Wqm(double l, double c, double p, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst) { double *Smatrix, *p0, *fn, *w, *z, dn, rn, cn, rn0, cn0, delta=0., q_minus=2., q_plus=3., mn_minus, mn_plus, nn, fSt, aSt, ratio, enumerator=0., nq, Wq=0., norm=1., arg=0., korr=1.; int i, j, n; fSt = 0.5; aSt = ( -2./log10(1.-fSt) - 1.)/19.; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); if ( mode==fir || mode==both ) delta = 2.*hs; Smatrix = matrix(N, N); w = vector(N); z = vector(N); fn = matrix(nmax, N); p0 = vector(nmax); switch ( subst ) { case IDENTITY: gausslegendre(N, -c, c, z, w); norm = 1.; break; case SIN: gausslegendre(N, -PI/2., PI/2., z, w); norm = 1.; break; case SINH: gausslegendre(N, -1., 1., z, w); norm = sinh(1.); break; case TAN: gausslegendre(N, -PI/4., PI/4., z, w); norm = 1.; break; } c /= norm; rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.; /* in-control, i. e. n<=q-1 */ for (n=1; n<=q-1; n++) { nn = (double) n; /* determine c_n and r_n, n=1,2,...,q-1 */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c*norm); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=1,2,...,q-1 */ if ( n==1 ) { for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i=q */ for (n=q; n<=nmax; n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c*norm); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0; i1 ) fn[(n-1)*N+i] /= p0[q-2]; } } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;i q ) { for (i=0; imn_plus ) mn_plus = ratio; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = nq + enumerator/log(mn_minus); q_plus = nq + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > q */ } /* p0[n-1] >= 1.-p */ } /* n=q; n<=nmax; n++ */ Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return Wq; } double xe1_Warl(double l, double c, double zr, double hs, double mu, int N, int nmax) { double *Pn, *w, *z, *p0, *atom, ratio, arl_minus=0., arl=1., arl_plus=0., mn_minus=1., mn_plus=0.; int i, j, n; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); zr *= sqrt( l/(2.-l) ); w = vector(N); z = vector(N); Pn = matrix(nmax,N); p0 = vector(nmax); atom = vector(nmax); gausslegendre(N,zr,c,z,w); for (n=1;n<=nmax;n++) { if (n==1) { for (i=0;i1) { mn_minus = atom[n-1]/atom[n-2]; mn_plus = atom[n-1]/atom[n-2]; for (i=0;imn_plus ) mn_plus = ratio; } arl_minus = arl + p0[n-1]/(1.-mn_minus); arl_plus = arl + p0[n-1]/(1.-mn_plus); } arl += p0[n-1]; if ( fabs( (arl_plus-arl_minus)/arl_minus )1 ) { mn_minus = atom[n-1]/atom[n-2]; mn_plus = atom[n-1]/atom[n-2]; for (i=0;imn_plus ) mn_plus = ratio; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(p0); Free(Pn); Free(z); Free(w); Free(atom); return Wq; } double xe1_Wqm(double l, double c, double p, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax) { double *Smatrix, *p0, *fn, *w, *z, rn, cn, rn0, cn0, q_minus=2., q_plus=3., mn_minus, mn_plus, nn, ratio, enumerator=0., nq, Wq=0.; int i, j, n, NN; c *= sqrt( l/(2.-l) ); zr *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); NN = N + 1; Smatrix = matrix(NN, NN); w = vector(NN); z = vector(NN); fn = matrix(nmax, NN); p0 = vector(nmax); gausslegendre(N, zr, c, z, w); rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.; /* in-control, i. e. n<=q-1 */ for (n=1;n<=q-1;n++) { nn = (double) n; /* determine r_n, n=1,2,...,q-1 */ if ( mode==vacl ) { rn = sqrt( 1. - pow(1.-l, 2.*nn) ); } /* determine f_n, n=1,2,...,q-1 */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ for (n=q;n<=nmax;n++) { nn = (double) n; /* determine r_n, n=1,2,...,q-1 */ if ( mode==vacl ) { rn = sqrt( 1. - pow(1.-l, 2.*nn) ); } /* determine f_n, n=q,q+1,... */ if (n==1) { for (i=0;i1 ) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*zr))/l, mu1); for (j=0;j1) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i q ) { for (i=0;imn_plus ) mn_plus = ratio; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = nq + enumerator/log(mn_minus); q_plus = nq + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > q */ } /* p0[n-1] >= 1.-p */ } /* n=q; n<=nmax; n++ */ Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return Wq; } double xe2_Carl(double l, double c, double hs, double mu, int N, int qm) { double *a, *g, *w, *z, arl, Hij, zi, lzi, dN; int i, j, k; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); dN = (double)N; a = matrix(N,N); g = vector(N); w = vector(qm); z = vector(qm); gausslegendre(qm,-c,c,z,w); for (i=0;i1)(zch[i]) */ for (i=0;i1) { for (i=0;imn_plusx ) mn_plusx = q; } for (i=0;imn_pluss ) mn_pluss = q; } mn_minus = mn_minusx * mn_minuss; mn_plus = mn_plusx * mn_pluss; arl_minus = arl + p0[n-1]/(1.-mn_minus); arl_plus = arl + p0[n-1]/(1.-mn_plus); } arl += p0[n-1]; if ( fabs( (arl_plus-arl_minus)/arl_minus )1)(zch[i]) */ for (i=0;i1) mu_before_sigma += ( p0s[n-2] - p0s[n-1] ) * p0x[n-1]; else mu_before_sigma = ( 1. - p0s[n-1] ) * p0x[n-1]; if ( p0s[n-1]1) mu_before_sigma += ( p0x[n-2]-p0x[n-1] ) * p0s[n-1]; else mu_before_sigma = ( 1.-p0x[n-1] ) * p0s[n-1]; if ( p0x[n-1]n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ for (n=q;n<=nmax;n++) { nn = (double) n; /* determine r_n, n=1,2,...,q-1 */ if ( mode==vacl ) { rn = sqrt( 1. - pow(1.-l, 2.*nn) ); } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0;i1 ) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*zr))/l, mu1); for (j=0;j1 ) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i=q */ for (n=q; n<=nmax; n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0; i1 ) fn[(n-1)*N+i] /= p0[q-2]; } } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i=q */ for (n=q; n<=nmax; n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c*norm); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0; i1 ) fn[(n-1)*N+i] /= p0[q-2]; } } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine r_n, n=1,2,...,q-1 */ if ( mode==vacl ) { rn = sqrt( 1. - pow(1.-l, 2.*nn) ); } /* determine f_n, n=q,q+1,... */ if (n==1) { for (i=0;i1) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*zr))/l, mu1); for (j=0;j1) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2; rho0 = rho; Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return arl; } double xe1_arlm_hom(double l, double c, double zr, double hs, int q, double mu0, double mu1, int N, double *ced) { double *fn, *w, *z, *a, *arl, norm; int i, j, n, NN; NN = N + 1; w = vector(NN); z = vector(NN); fn = matrix(q+1, NN); a = matrix(NN,NN); arl = vector(NN); c *= sqrt( l/(2.-l) ); zr *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); gausslegendre(N, zr, c, z, w); /* ARL vector */ for (i=0; i 1 */ for (n=1; n<=q-1; n++) { if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine f_n, n=q,q+1,... */ if (n==1) { for (i=0;i1) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (zr-l1*zr)/l2, mu1); for (j=0;j1) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( (p0[n-1]>p0[n-2] || rho>1.) && n>10 ) error("invalid ARL value"); if ( fabs((arl_plus-arl_minus)) < 1e-5 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2; rho0 = rho; Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return arl; } double xe2_arlm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax) { double *Smatrix, *p0, *fn, *w, *z, arl0, rho, dn, rn, cn, rn0, cn0, delta=0., arl_minus=0, arl, arl_plus=0, mn_minus, mn_plus, nn, fSt, aSt, ratio; int i, j, n; fSt = 0.5; aSt = ( -2./log10(1.-fSt) - 1.)/19.; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); if (mode==fir || mode==both) delta = 2.*hs; Smatrix = matrix(N,N); w = vector(N); z = vector(N); fn = matrix(nmax,N); p0 = vector(nmax); gausslegendre(N,-c,c,z,w); rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.; /* in-control, i. e. n<=q-1 */ for (n=1;n<=q-1;n++) { nn = (double) n; /* determine c_n and r_n, n=1,2,...,q-1 */ switch (mode) { case vacl: rn = sqrt( 1. - pow(1.-l, 2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=1,2,...,q-1 */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch (mode) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if (n==1) { for (i=0;i1) fn[(n-1)*N+i] /= p0[q-2]; } } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2; rho0 = rho; Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return arl; } int xe2_arlm_special(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *pair) { double *Smatrix, *p0, *fn, *w, *z, arl0, rho, dn, rn, cn, rn0, cn0, delta=0., arl_minus=0, arl, arl_plus=0, mn_minus, mn_plus, nn, fSt, aSt, ratio; int i, j, n; fSt = 0.5; aSt = ( -2./log10(1.-fSt) - 1.)/19.; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); if (mode==fir || mode==both) delta = 2.*hs; Smatrix = matrix(N,N); w = vector(N); z = vector(N); fn = matrix(nmax,N); p0 = vector(nmax); gausslegendre(N,-c,c,z,w); rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.; /* in-control, i. e. n<=q-1 */ for (n=1;n<=q-1;n++) { nn = (double) n; /* determine c_n and r_n, n=1,2,...,q-1 */ switch (mode) { case vacl: rn = sqrt( 1. - pow(1.-l, 2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=1,2,...,q-1 */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch (mode) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if ( n > q ) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = ( arl_plus + arl_minus )/2; pair[0] = 1.; if ( q > 1 ) pair[0] = p0[q-2]; pair[1] = arl; Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return 0; } double xte2_arlm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst) { double *Smatrix, *p0, *fn, *w, *z, arl0, rho, dn, rn, cn, rn0, cn0, delta=0., arl_minus=0, arl, arl_plus=0, mn_minus, mn_plus, nn, fSt, aSt, ratio, norm=1., arg=0., korr=1.; int i, j, n; fSt = 0.5; aSt = ( -2./log10(1.-fSt) - 1.)/19.; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); if (mode==fir || mode==both) delta = 2.*hs; Smatrix = matrix(N,N); w = vector(N); z = vector(N); fn = matrix(nmax,N); p0 = vector(nmax); switch ( subst ) { case IDENTITY: gausslegendre(N, -c, c, z, w); norm = 1.; break; case SIN: gausslegendre(N, -PI/2., PI/2., z, w); norm = 1.; break; case SINH: gausslegendre(N, -1., 1., z, w); norm = sinh(1.); break; case TAN: gausslegendre(N, -PI/4., PI/4., z, w); norm = 1.; break; } c /= norm; rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.; /* in-control, i. e. n<=q-1 */ for (n=1; n<=q-1; n++) { nn = (double) n; /* determine c_n and r_n, n=1,2,...,q-1 */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l, 2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c*norm); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=1,2,...,q-1 */ if ( n==1 ) { for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i=q */ arl0 = 1.; rho = 0.; for (n=q; n<=nmax; n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c*norm); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0; i1 ) fn[(n-1)*N+i] /= p0[q-2]; } } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;iq ) { for (i=0; imn_plus ) mn_plus = ratio; } } if ( n>q ) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if ( mn_minus<1. ) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if ( mn_plus<1. ) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2; rho0 = rho; Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return arl; } double xe2_arlm_hom(double l, double c, double hs, int q, double mu0, double mu1, int N, double *ced) { double *fn, *w, *z, *a, *arl, norm; int i, j, n; w = vector(N); z = vector(N); fn = matrix(q+1, N); a = matrix(N,N); arl = vector(N); c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); gausslegendre(N, -c, c, z, w); for (i=0; i 1 */ for (n=1; n<=q-1; n++) { if ( n==1 ) { for (i=0; i 1 */ for (n=1; n<=q-1; n++) { if ( n==1 ) { for (i=0; i 1000 ) qm = 1000;*/ return qm; } /* routines for prerun impact on average ARL, QRL performance */ /* 1. ARL (fixed limits) */ double xe2_iglarl_prerun_MU(double l, double c, double hs, double mu, int pn, int qm, double truncate) { double *w, *z, b, result, dn, sdn; int i, Nlocal; w = vector(qm); z = vector(qm); dn = (double)pn; sdn = sqrt(dn); b = -qPHI(truncate/2.)/sdn; gausslegendre(qm, -b, b, z, w); Nlocal = qm_for_l_and_c(l, c); result = 0.; for (i=0; i1 ) { for (i=0;imn_plus ) mn_plus = ratio; } *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < BOUND ) { *nstop = n; n = nmax + 1; } } } Free(Pn); Free(z); Free(w); Free(Sm); return 0; } double xe2_sfm_simple(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0) { double *Smatrix, *fn, *w, *z, dn, rn, cn, rn0, cn0, delta=0., nn, fSt, aSt; int i, j, n; fSt = 0.5; aSt = ( -2./log10(1.-fSt) - 1.)/19.; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); if ( mode==fir || mode==both ) delta = 2.*hs; Smatrix = matrix(N, N); w = vector(N); z = vector(N); fn = matrix(nmax, N); gausslegendre(N, -c, c, z, w); rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.; /* in-control, i. e. n<=q-1 */ for (n=1; n<=q-1; n++) { nn = (double) n; /* determine c_n and r_n, n=1,2,...,q-1 */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=1,2,...,q-1 */ if ( n==1 ) { for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i=q */ for (n=q; n<=nmax; n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i=q */ for (n=q; n<=nmax; n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; iq ) { for (i=0;imn_plus ) mn_plus = ratio; } *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < BOUND ) { *nstop = n; n = nmax + 1; } } } Free(Smatrix); Free(w); Free(z); Free(fn); return 0; } /* Survival function P(L>n) */ double xe2_sf_prerun_MU_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0) { double *ww, *zz, b, dn, sdn, *SF, rho; int i, m, n, nstop, Nlocal; SF = vector(nmax); ww = vector(qm); zz = vector(qm); dn = (double)pn; sdn = sqrt(dn); b = -qPHI(truncate/2.)/sdn; gausslegendre(qm, -b, b, zz, ww); for (i=0; i 0 ) { for (n=0; n 0 ) { for (n=0; n 1 ) for (n=q-1; n 1 ) for (n=q-1; n 0 ) { for (n=0; n 0 ) { for (n=0; n 1 ) for (n=q-1; n 1 ) for (n=q-1; n 0 ) { for (n=0; n 0 ) { for (n=0; n 1 ) for (n=q-1; n 1 ) for (n=q-1; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; j = xe2_sf_deluxe(l, c, hs, zz[qnspecial-1]+mu, Nlocal, nmax, BOUND, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 0 ) n--; if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.; } else { for (n=nn; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; j = xe2_sfm_deluxe(l, c, hs, q, zz[qnspecial-1]+mu0, zz[qnspecial-1]+mu1, mode, Nlocal, nmax, BOUND, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 1 ) sf_level_adj *= p0[q-2]; if ( p0[nn-1] <= sf_level_adj ) { n = nn-1; while ( p0[n] <= sf_level_adj && n > 0 ) n--; if ( p0[n] > sf_level_adj ) Lp = (double)( n + 2 - q + 1 ); else Lp = 1.; } else { for (n=nn; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; Nlocal = qm_for_l_and_c(l, zz[qnspecial-1]*c); j = xe2_sf_deluxe(l, zz[qnspecial-1]*c, hs, mu, Nlocal, nmax, BOUND, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 0 ) n--; if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.; } else { for (n=nn; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; Nlocal = qm_for_l_and_c(l, zz[qnspecial-1]*c); j = xe2_sfm_deluxe(l, zz[qnspecial-1]*c, hs, q, mu0, mu1, mode, Nlocal, nmax, BOUND, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 1 ) sf_level_adj *= p0[q-2]; if ( p0[nn-1] <= sf_level_adj ) { n = nn-1; while ( p0[n] <= sf_level_adj && n > 0 ) n--; if ( p0[n] > sf_level_adj ) Lp = (double)( n + 2 - q + 1 ); else Lp = 1.; } else { for (n=nn; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n nstop ) { for (n=nstop; n 0 ) n--; if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.; } else { for (n=nn; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n nstop ) { for (n=nstop; n 1 ) sf_level_adj *= p0[q-2]; if ( p0[nn-1] <= sf_level_adj ) { n = nn-1; while ( p0[n] <= sf_level_adj && n > 0 ) n--; if ( p0[n] > sf_level_adj ) Lp = (double)( n + 2 - q + 1 ); else Lp = 1.; } else { for (n=nn; nz2) a[i1*N3+j1*NN+i2*N+j2] = 0.; else a[i1*N3+j1*NN+i2*N+j2] = -PHI(z2,mu1) + PHI(z1,mu1); if (i1==i2 && j1==j2) a[i1*N3+j1*NN+i2*N+j2]++; } for (j1=0;j1z2) a[i2*N3+j2*NN+i1*N+j1] = 0.; else a[i2*N3+j2*NN+i1*N+j1] = PHI(z2,mu0) - PHI(z1,mu0); } pmethod(NN,a,&status,&rho,psi,&noofit); ad = 0.; norm = 0.; for (i1=0;i1 5 ) result = cos( (double)(n)*acos(z) ); } else { if ( z<0. && (n % 2 == 1) ) result = -1.; else result = 1.; } return result; } /* -------------- indefinite integrals of Chebyshev polynomials on [-1,1] ----------------- */ double iTn(double z, int n) { double result=1.; switch (n) { case 0: result = z; break; case 1: result = z*z/2.; break; case 2: result = 2.*z*z*z/3. - z; break; } if ( n > 2 ) result = ( Tn(z,n+1)/(n+1.) - Tn(z,n-1)/(n-1.) )/2.; return result; } /* -------------- derivatives of Chebyshev polynomials on [-1,1] ----------------- */ double dTn(double z, int n) { double result=1., dn; dn = (double)n; if ( fabs(z)<1-1e-12 ) { switch (n) { case 0: result = 0.; break; case 1: result = 1.; break; case 2: result = 4.*z; break; case 3: result = 12.*z*z-3.; break; case 4: result = 32.*z*z*z-16.*z; break; case 5: result = 80.*pow(z,4.)-60.*z*z+5.; break; } if ( n > 5 ) result = dn * ( Tn(z,n-1) - z*Tn(z,n) ) / (1.-z*z); } else { if ( z<0. && (n % 2 == 0) ) result = -dn*dn; else result = dn*dn; } return result; } double seU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm) { double *a, *g, *w, *z, arl, Hij, xi, xl, za, xu, dN, ddf, s2, v; int i, j, k; s2 = sigma*sigma; ddf = (double)df; dN = (double)N; a = matrix(N,N); g = vector(N); w = vector(qm); z = vector(qm); for (i=0;i1)(zch[i]) */ for (i=0; i1)(zch[i]) */ for (i=0; i 1 ) { for (i=0; imn_plus ) mn_plus = q; } *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < FINALeps ) { *nstop = n; n = nmax + 1; } } /* n > 1 */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); return 0; } int choose_N_for_seU(double lambda) { int N=20; N = 25; if ( 0.1 <= lambda && lambda < 0.2 ) N = 35; if ( 0.05 <= lambda && lambda < 0.1 ) N = 50; if ( 0.02 <= lambda && lambda < 0.05) N = 70; if ( 0.01 <= lambda && lambda < 0.02) N = 100; if ( lambda < 0.01 ) N = 150; return N; } int choose_N_for_se2(double lambda, double cl, double cu) { int N=20, M=1; M = ceil( ( log(cl) - log(cu) )/log( 1. - lambda ) ); N = 5; if ( 0.1 <= lambda && lambda < 0.2 ) N = 10; if ( 0.05 <= lambda && lambda < 0.1 ) N = 20; if ( 0.02 <= lambda && lambda < 0.05) N = 40; if ( 0.01 <= lambda && lambda < 0.02) N = 60; if ( lambda < 0.01 ) N = 90; N *= M; if ( N < 30 ) N = 30; if ( N > 200 ) N = 200; return N; } double seU_sf_prerun_SIGMA_deluxe(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0) { double *ww, *zz, b1, b2, ddf2, *SF, rho, s2; int i, m, n, nstop, Nlocal; Nlocal = choose_N_for_seU(l); SF = vector(nmax); ww = vector(qm2); zz = vector(qm2); ddf2 = (double)(df2); b1 = qCHI( truncate/2., df2)/ddf2; b2 = qCHI(1. - truncate/2., df2)/ddf2; gausslegendre(qm2, b1, b2, zz, ww); for (i=0; i 0 ) { for (n=0; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; s2 = zz[qnspecial-1]; j = seU_sf_deluxe(l, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 0 ) n--; if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.; } else { for (n=nn; n1)(zch[i]) */ for (i=0; i 1 ) { for (i=0; imn_plus ) mn_plus = q; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); /*if ( fabs( (q_plus-q_minus)/q_minus ) 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(p0); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); return Wq; } double seU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3, norm; norm = sqrt(df); s2 = hs - .15; L2 = 0.; do { s1 = s2; L1 = L2; s2 += .2/norm; L2 = seU_iglarl(l,s2,hs,sigma,df,N,qm); } while ( L2 < L0 ); do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = seU_iglarl(l,s3,hs,sigma,df,N,qm); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-9 ); return s3; } double stdeU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3, norm; norm = sqrt(df); s2 = hs - .15; L2 = 0.; do { s1 = s2; L1 = L2; s2 += .2/norm; L2 = stdeU_iglarl(l,s2,hs,sigma,df,N,qm); } while ( L2 < L0 ); do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = stdeU_iglarl(l,s3,hs,sigma,df,N,qm); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-9 ); return s3; } double seU_crit_prerun_SIGMA(double l, double L0, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate) { double s1, s2, s3, ds, L1=0., L2=0., L3=0.; s2 = hs; do { L1 = L2; s2 += .2; L2 = seU_iglarl_prerun_SIGMA(l, s2, hs, sigma, df1, df2, N, qm1, qm2, truncate); } while ( L2 < L0 ); s1 = s2 - .2; do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = seU_iglarl_prerun_SIGMA(l, s3, hs, sigma, df1, df2, N, qm1, qm2, truncate); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-9 ); return s3; } double seU_q_crit(double l, int L0, double alpha, double hs, double sigma, int df, int N, int qm, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = hs; p2 = 1.; do { p1 = p2; s2 += .2; result = seU_sf(l, s2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in seU_q_crit [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha ); s1 = s2 - .2; do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); result = seU_sf(l, s3, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in seU_q_crit [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double seU_q_crit_prerun_SIGMA(double l, int L0, double alpha, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = seU_q_crit(l, L0, alpha, hs, sigma, df1, N, qm1, c_error, a_error); if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seU_sf_prerun_SIGMA(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seU_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; if ( p2 > alpha ) { do { p1 = p2; s2 += .2; if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seU_sf_prerun_SIGMA(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seU_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha ); s1 = s2 - .2; } else { do { p1 = p2; s2 -= .2; if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seU_sf_prerun_SIGMA(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seU_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 <= alpha && s2 > hs ); s1 = s2 + .2; } do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seU_sf_prerun_SIGMA(l, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seU_q_crit_prerun_SIGMA [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double se2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm) { double *a, *g, *w, *z, *t, h, arl, Hij, xl, za, dN, ddf, s2, t0, t1, x0, x1; int i, j, k, qi, qj, M, Ntilde, NN, ii, it, jj; M = ceil( (log(cl) - log(cu))/log(1.-l) ); Ntilde = ceil( (double)N/(double)M ); NN = M*Ntilde; s2 = sigma*sigma; ddf = (double)df; dN = (double)Ntilde - 1.; a = matrix(NN, NN); g = vector(NN); t = vector(NN); w = vector(qm); z = vector(qm); for(i=0;icu) t1 = cu; for (j=1;j0) { qi = i-1; t0 = cl/pow(1.-l,(double)qi); t1 = t0/(1.-l); if (t1>cu) t1 = cu; if (t01e-10) x0 = sqrt(x0-za); else x0 = 0.; if (t1-za>1e-10) x1 = sqrt(t1-za); else x1 = 0.; } for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; if (j==1) a[ii*NN+jj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1); else { if (fabs(t1-x0)>1e-8) { gausslegendre(qm,x0,x1,z,w); Hij = 0.; for (k=0;kcu) t1 = cu; if (t01e-10) x0 = sqrt(x0-za); else x0 = 0.; if (t1-za>1e-10) x1 = sqrt(t1-za); else x1 = 0.; } if (i>0 && j==1 && qi==i) { for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1); } } if (i>0 && j==1 && qi>i) { for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = 0.; } } if (i==0 || j>1) { for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; gausslegendre(qm,x0,x1,z,w); Hij = 0.; for (k=0;kcu) t1 = cu; if (t0<=hs && hscu ) t1 = cu; for (j=1; j0 ) { qi = i-1; t0 = cl/pow(1.-l,(double)qi); t1 = t0/(1.-l); if ( t1>cu ) t1 = cu; if ( t01e-8 ) { gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; kcu ) t1 = cu; if ( t00 && j==1 && qi==i ) { for (qj=1; qj<=Ntilde; qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1); } } if ( i>0 && j==1 && qi>i ) { for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = 0.; } } if ( i==0 || j>1 ) { for ( qj=1; qj<=Ntilde; qj++) { jj = qi*Ntilde + qj-1; gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; kcu ) t1 = cu; if ( t0<=hs && hs1)(zch[i,j]) */ for (i=0; i1)(zch[i,j]) */ for (i=0; i 1) { for (i=0; imn_plus ) mn_plus = q; } *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < FINALeps ) { *nstop = n; n = nmax + 1; } } /* n > 1 */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); return 0; } double se2_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0) { double *ww, *zz, b1, b2, ddf2, *SF, rho, s2; int i, m, n, nstop, Nlocal; Nlocal = choose_N_for_se2(l, cl, cu); SF = vector(nmax); ww = vector(qm2); zz = vector(qm2); ddf2 = (double)(df2); b1 = qCHI( truncate/2., df2)/ddf2; b2 = qCHI(1. - truncate/2., df2)/ddf2; gausslegendre(qm2, b1, b2, zz, ww); for (i=0; i 0 ) { for (n=0; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; s2 = zz[qnspecial-1]; j = se2_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 0 ) n--; if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.; } else { for (n=nn; n1)(zch[i,j]) */ for (i=0; i 1) { for (i=0; imn_plus ) mn_plus = q; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); /*if ( fabs( (q_plus-q_minus)/q_minus ) 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(p0); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); return Wq; } double se2lu_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3; s2 = hs; do { s2 += .2; L2 = se2_iglarl(l,cl,s2,hs,sigma,df,N,qm); } while ( L2 < L0 ); s1 = s2 - .2; L1 = se2_iglarl(l,cl,s1,hs,sigma,df,N,qm); do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = se2_iglarl(l,cl,s3,hs,sigma,df,N,qm); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-9 ); return s3; } double stde2lu_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3; s2 = hs; L2 = 0.; do { s1 = s2; L1 = L2; s2 += .2; L2 = stde2_iglarl(l, cl, s2, hs, sigma, df, N, qm); } while ( L2 < L0 ); do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = stde2_iglarl(l, cl, s3, hs, sigma, df, N, qm); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-9 ); return s3; } double se2lu_crit_prerun_SIGMA(double l, double L0, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate) { double s1, s2, s3, ds, L1=0., L2=0., L3=0.; s2 = hs; do { L1 = L2; s2 += .2; L2 = se2_iglarl_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, N, qm1, qm2, truncate); } while ( L2 < L0 ); s1 = s2 - .2; do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = se2_iglarl_prerun_SIGMA(l, cl, s3, hs, sigma, df1, df2, N, qm1, qm2, truncate); ds = s3 - s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-9 ); return s3; } double se2lu_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = hs; p2 = 1.; do { p1 = p2; s2 += .2; result = se2_sf(l, cl, s2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2lu_q_crit [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha ); s1 = s2 - .2; do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); result = se2_sf(l, cl, s3, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2lu_q_crit [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double se2lu_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = se2lu_q_crit(l, L0, alpha, cl, hs, sigma, df1, N, qm1, c_error, a_error); if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2lu_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; if ( p2 > alpha ) { do { p1 = p2; s2 += .2; if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2lu_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha ); s1 = s2 - .2; } else { do { p1 = p2; s2 -= .2; if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2lu_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 <= alpha && s2 > hs ); s1 = s2 + .2; } do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, cl, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, cl, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2lu_q_crit_prerun_SIGMA [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double se2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3, norm; norm = sqrt(df); s2 = 2. - cu; if ( s2 < 0.1 ) s2 = 0.1; L2 = se2_iglarl(l,s2,cu,hs,sigma,df,N,qm); if ( L2 < L0 ) { do { s2 -= .2/norm; L2 = se2_iglarl(l,s2,cu,hs,sigma,df,N,qm); } while ( L2 < L0 ); s1 = s2 + .2/norm; } else { do { s2 += .2/norm; L2 = se2_iglarl(l,s2,cu,hs,sigma,df,N,qm); } while ( L2 > L0 ); s1 = s2 - .2/norm; } L1 = se2_iglarl(l,s1,cu,hs,sigma,df,N,qm); do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = se2_iglarl(l,s3,cu,hs,sigma,df,N,qm); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-9 ); return s3; } double stde2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3, norm; norm = sqrt(df); s2 = 2. - cu; if ( s2 < 0.1 ) s2 = 0.1; L2 = stde2_iglarl(l, s2, cu, hs, sigma, df, N, qm); if ( L2 < L0 ) { do { s1 = s2; L1 = L2; s2 -= .2/norm; L2 = stde2_iglarl(l, s2, cu, hs, sigma, df, N, qm); } while ( L2 < L0 ); } else { do { s1 = s2; L1 = L2; s2 += .2/norm; L2 = stde2_iglarl(l, s2, cu, hs, sigma, df, N, qm); } while ( L2 > L0 ); } do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = stde2_iglarl(l, s3, cu, hs, sigma, df, N,qm); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-9 ); return s3; } double se2fu_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate) { double s1, s2, s3, ds, L1=0., L2=0., L3=0.; s2 = cu/2.; L2 = se2_iglarl_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate); if ( L2 < L0 ) { do { L1 = L2; s2 -= .1; L2 = se2_iglarl_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate); } while ( L2 < L0 && s2 > 0.); s1 = s2 + .1; } else { do { L1 = L2; s2 += .1; L2 = se2_iglarl_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate); } while ( L2 > L0 && s2 < hs ); s1 = s2 - .1; } do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = se2_iglarl_prerun_SIGMA(l, s3, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-9 ); return s3; } double se2fu_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = cu/2.; result = se2_sf(l, s2, cu, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit [package spc]"); p2 = 1. - SF[L0-1]; if ( p2 < alpha ) { do { p1 = p2; s2 += .1; result = se2_sf(l, s2, cu, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 < alpha ); s1 = s2 - .1; } else { do { p1 = p2; s2 -= .1; result = se2_sf(l, s2, cu, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 >= alpha ); s1 = s2 + .1; } do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); result = se2_sf(l, s3, cu, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double se2fu_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1, schritt=0, maxschritt=30; SF = vector(L0); s2 = se2fu_q_crit(l, L0, alpha, cu, hs, sigma, df1, N, qm1, c_error, a_error); if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; if ( p2 < alpha ) { do { p1 = p2; s2 += .1; if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 < alpha && s2 < hs ); s1 = s2 - .1; } else { do { p1 = p2; s2 -= .1; if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 >= alpha && s2 > 0. ); s1 = s2 + .1; } schritt = 0; do { schritt++; s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, s3, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, s3, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit_prerun_SIGMA [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error && schritt= maxschritt ) warning("secant rule in se2fu_q_crit_prerun_SIGMA did not converge"); Free(SF); return s3; } int se2_crit_prerun_SIGMA(double l, double L0, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate) { double s1, s2, s3, ds, sl1, sl2, sl3, csl, Lm, Lp; csl = hs/2.; s1 = se2lu_crit_prerun_SIGMA(l, L0, csl, hs, sigma, df1, df2, N, qm1, qm2, truncate); Lm = se2_iglarl_prerun_SIGMA(l, csl, s1, hs, sigma-lmEPS, df1, df2, N, qm1, qm2, truncate); Lp = se2_iglarl_prerun_SIGMA(l, csl, s1, hs, sigma+lmEPS, df1, df2, N, qm1, qm2, truncate); sl1 = (Lp-Lm)/(2.*lmEPS); s2 = s1 + .05; csl = se2fu_crit_prerun_SIGMA(l, L0, s2, hs, sigma, df1, df2, N, qm1, qm2, truncate); Lm = se2_iglarl_prerun_SIGMA(l, csl, s2, hs, sigma-lmEPS, df1, df2, N, qm1, qm2, truncate); Lp = se2_iglarl_prerun_SIGMA(l, csl, s2, hs, sigma+lmEPS, df1, df2, N, qm1, qm2, truncate); sl2 = (Lp-Lm)/(2.*lmEPS); do { s3 = s1 - sl1/(sl2-sl1) * (s2-s1); csl = se2fu_crit_prerun_SIGMA(l, L0, s3, hs, sigma, df1, df2, N, qm1, qm2, truncate); Lm = se2_iglarl_prerun_SIGMA(l, csl, s3, hs, sigma-lmEPS, df1, df2, N, qm1, qm2, truncate); Lp = se2_iglarl_prerun_SIGMA(l, csl, s3, hs, sigma+lmEPS, df1, df2, N, qm1, qm2, truncate); sl3 = (Lp-Lm)/(2.*lmEPS); ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; } while ( fabs(sl3)>1e-6 && fabs(ds)>1e-9 ); *cl = csl; *cu = s3; return 0; } int se2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, sl1, sl2, sl3, csl, Lm, Lp, step; step = .1/sqrt(df); s1 = seU_crit(l,L0,hs,sigma,df,N,qm); csl = 0.; Lm = seU_iglarl(l,s1,hs,sigma-lmEPS,df,N,qm); Lp = seU_iglarl(l,s1,hs,sigma+lmEPS,df,N,qm); sl1 = (Lp-Lm)/(2.*lmEPS); s2 = s1; sl2 = sl1; do { s1 = s2; sl1 = sl2; s2 = s1 + step; csl = se2fu_crit(l,L0,s2,hs,sigma,df,N,qm); Lm = se2_iglarl(l,csl,s2,hs,sigma-lmEPS,df,N,qm); Lp = se2_iglarl(l,csl,s2,hs,sigma+lmEPS,df,N,qm); sl2 = (Lp-Lm)/(2.*lmEPS); } while ( sl2 < 0. ); do { s3 = s1 - sl1/(sl2-sl1) * (s2-s1); csl = se2fu_crit(l,L0,s3,hs,sigma,df,N,qm); Lm = se2_iglarl(l,csl,s3,hs,sigma-lmEPS,df,N,qm); Lp = se2_iglarl(l,csl,s3,hs,sigma+lmEPS,df,N,qm); sl3 = (Lp-Lm)/(2.*lmEPS); ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; } while ( fabs(sl3)>1e-7 && fabs(ds)>1e-9 ); *cl = csl; *cu = s3; return 0; } int stde2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, sl1, sl2, sl3, csl, Lm, Lp, step; step = .1/sqrt(df); s1 = stdeU_crit(l, L0, hs, sigma, df, N, qm); csl = 0.; Lm = stdeU_iglarl(l, s1, hs, sigma-lmEPS, df, N, qm); Lp = stdeU_iglarl(l, s1, hs, sigma+lmEPS, df, N, qm); sl1 = (Lp-Lm)/(2.*lmEPS); s2 = s1; sl2 = sl1; do { s1 = s2; sl1 = sl2; s2 = s1 + step; csl = stde2fu_crit(l, L0, s2, hs, sigma, df, N, qm); Lm = stde2_iglarl(l, csl, s2, hs, sigma-lmEPS, df, N, qm); Lp = stde2_iglarl(l, csl, s2, hs, sigma+lmEPS, df, N, qm); sl2 = (Lp-Lm)/(2.*lmEPS); } while ( sl2 < 0. ); do { s3 = s1 - sl1/(sl2-sl1) * (s2-s1); csl = stde2fu_crit(l, L0, s3, hs, sigma, df, N, qm); Lm = stde2_iglarl(l, csl, s3, hs, sigma-lmEPS, df, N, qm); Lp = stde2_iglarl(l, csl, s3, hs, sigma+lmEPS, df, N, qm); sl3 = (Lp-Lm)/(2.*lmEPS); ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; } while ( fabs(sl3)>1e-7 && fabs(ds)>1e-9 ); *cl = csl; *cu = s3; return 0; } int se2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm) { double u1, u2, du, l1, l2, dl, lARL1, lARL2, uARL1, uARL2, ARL22, ARL12, ARL21, f11, f22, f21, f12, d11, d22, d21, d12, nenner; l1 = seLR_crit(l, 2.*L0, ur, hs, sigma, df, N, qm); l2 = l1 - .05; u1 = seU_crit(l, 2.*L0, hs, sigma, df, N, qm); u2 = u1 + .05; ARL22 = se2_iglarl(l, l1, u1, hs, sigma, df, N, qm); lARL2 = seLR_iglarl(l, l2, ur, hs, sigma, df, N, qm); uARL2 = seU_iglarl(l, u2, hs, sigma, df, N, qm); ARL22 = se2_iglarl(l, l2, u2, hs, sigma, df, N, qm); do { lARL1 = seLR_iglarl(l, l1, ur, hs, sigma, df, N, qm); uARL1 = seU_iglarl(l, u1, hs, sigma, df, N, qm); ARL12 = se2_iglarl(l, l1, u2, hs, sigma, df, N, qm); ARL21 = se2_iglarl(l, l2, u1, hs, sigma, df, N, qm); /* difference quotient */ f11 = (ARL22 - ARL12)/(l2-l1); f12 = (ARL22 - ARL21)/(u2-u1); f21 = (lARL2 - lARL1)/(l2-l1); f22 = (uARL1 - uARL2)/(u2-u1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dl = d11*(ARL22-L0) + d12*(lARL2-uARL2); du = d21*(ARL22-L0) + d22*(lARL2-uARL2); l1 = l2; u1 = u2; l2 -= dl; u2 -= du; lARL2 = seLR_iglarl(l, l2, ur, hs, sigma, df, N, qm); uARL2 = seU_iglarl(l, u2, hs, sigma, df, N, qm); ARL22 = se2_iglarl(l, l2, u2, hs, sigma, df, N, qm); } while ( (fabs(L0-ARL22)>1e-6 || fabs(lARL2-uARL2)>1e-6) && (fabs(l2-l1)>1e-9 || fabs(u2-u1)>1e-9) ); *cl = l2; *cu = u2; return 0; } int stde2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm) { double u1, u2, du, l1, l2, dl, lARL1, lARL2, uARL1, uARL2, ARL22, ARL12, ARL21, f11, f22, f21, f12, d11, d22, d21, d12, nenner; l1 = stdeLR_crit(l, 2.*L0, ur, hs, sigma, df, N, qm); l2 = l1 - .05; u1 = stdeU_crit(l, 2.*L0, hs, sigma, df, N, qm); u2 = u1 + .05; ARL22 = stde2_iglarl(l, l1, u1, hs, sigma, df, N, qm); lARL2 = stdeLR_iglarl(l, l2, ur, hs, sigma, df, N, qm); uARL2 = stdeU_iglarl(l, u2, hs, sigma, df, N, qm); ARL22 = stde2_iglarl(l, l2, u2, hs, sigma, df, N, qm); do { lARL1 = stdeLR_iglarl(l, l1, ur, hs, sigma, df, N, qm); uARL1 = stdeU_iglarl(l, u1, hs, sigma, df, N, qm); ARL12 = stde2_iglarl(l, l1, u2, hs, sigma, df, N, qm); ARL21 = stde2_iglarl(l, l2, u1, hs, sigma, df, N, qm); /* difference quotient */ f11 = (ARL22 - ARL12)/(l2-l1); f12 = (ARL22 - ARL21)/(u2-u1); f21 = (lARL2 - lARL1)/(l2-l1); f22 = (uARL1 - uARL2)/(u2-u1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dl = d11*(ARL22-L0) + d12*(lARL2-uARL2); du = d21*(ARL22-L0) + d22*(lARL2-uARL2); l1 = l2; u1 = u2; l2 -= dl; u2 -= du; lARL2 = stdeLR_iglarl(l, l2, ur, hs, sigma, df, N, qm); uARL2 = stdeU_iglarl(l, u2, hs, sigma, df, N, qm); ARL22 = stde2_iglarl(l, l2, u2, hs, sigma, df, N, qm); } while ( (fabs(L0-ARL22)>1e-6 || fabs(lARL2-uARL2)>1e-6) && (fabs(l2-l1)>1e-9 || fabs(u2-u1)>1e-9) ); *cl = l2; *cu = u2; return 0; } double se2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm) { double cu1, cu2, cu3, cl1, cl2, cl3, L1, L2, L3, du, step; cu2 = seU_crit(l, L0, hs, sigma, df, N, qm); if ( cu2 < 2. ) { step = (2.-cu2)/10.; cu2 += step; cl2 = 2. - cu2; L2 = se2_iglarl(l, cl2, cu2, hs, sigma, df, N, qm); cu1 = cu2 + step; cl1 = 2. - cu1; L1 = se2_iglarl(l, cl1, cu1, hs, sigma, df, N, qm); do { cu3 = cu1 + (L0-L1)/(L2-L1) * (cu2-cu1); cl3 = 2. - cu3; L3 = se2_iglarl(l, cl3, cu3, hs, sigma, df, N, qm); du = cu3-cu2; cu1 = cu2; L1 = L2; cu2 = cu3; L2 = L3; if ( L3 < 1. ) error("invalid ARL value"); } while ( (fabs(L0-L3)>1e-6) && (fabs(du)>1e-9) ); } else { error("symmetric design not possible"); cu3 = -1.; } return cu3; } double stde2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm) { double cu1, cu2, cu3, cl1, cl2, cl3, L1, L2, L3, du, step, mitte; mitte = c_four((double)df); cu2 = stdeU_crit(l, L0, hs, sigma, df, N, qm); if ( cu2 < 2. ) { step = (2.-cu2)/10.; cu2 += step; cl2 = 2.*mitte - cu2; L2 = stde2_iglarl(l, cl2, cu2, hs, sigma, df, N, qm); cu1 = cu2 + step; cl1 = 2.*mitte - cu1; L1 = stde2_iglarl(l, cl1, cu1, hs, sigma, df, N, qm); do { cu3 = cu1 + (L0-L1)/(L2-L1) * (cu2-cu1); cl3 = 2.*mitte - cu3; L3 = stde2_iglarl(l, cl3, cu3, hs, sigma, df, N, qm); du = cu3-cu2; cu1 = cu2; L1 = L2; cu2 = cu3; L2 = L3; if ( L3 < 1. ) error("invalid ARL value"); } while ( (fabs(L0-L3)>1e-7) && (fabs(du)>1e-9) ); } else { error("symmetric design not possible"); cu3 = -1.; } return cu3; } int se2_q_crit(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error) { double s1, s2, s3, ds, sl1, sl2, sl3, csl, Pm, Pp, *SF; int result=1; SF = vector(L0); s1 = seU_q_crit(l, L0, alpha, hs, sigma, df, N, qm, c_error, a_error); csl = 0.; result = seU_sf(l, s1, hs, sigma-lmEPS, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit [package spc]"); Pm = 1. - SF[L0-1]; result = seU_sf(l, s1, hs, sigma+lmEPS, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit [package spc]"); Pp = 1. - SF[L0-1]; sl1 = ( Pp - Pm )/(2.*lmEPS); s2 = s1 + .05; csl = se2fu_q_crit(l, L0, alpha, s2, hs, sigma, df, N, qm, c_error, a_error); result = se2_sf(l, csl, s2, hs, sigma-lmEPS, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit [package spc]"); Pm = 1. - SF[L0-1]; result = se2_sf(l, csl, s2, hs, sigma+lmEPS, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit [package spc]"); Pp = 1. - SF[L0-1]; sl2 = ( Pp - Pm )/(2.*lmEPS); do { s3 = s1 - sl1/(sl2-sl1) * (s2-s1); csl = se2fu_q_crit(l, L0, alpha, s3, hs, sigma, df, N, qm, c_error, a_error); result = se2_sf(l, csl, s3, hs, sigma-lmEPS, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit [package spc]"); Pm = 1. - SF[L0-1]; result = se2_sf(l, csl, s3, hs, sigma+lmEPS, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit [package spc]"); Pp = 1. - SF[L0-1]; sl3 = ( Pp - Pm )/(2.*lmEPS); ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; } while ( fabs(sl3)>a_error && fabs(ds)>c_error ); *cl = csl; *cu = s3; Free(SF); return 0; } int se2_q_crit_class(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm, double c_error, double a_error) { double u1, u2, du, l1, l2, dl, lA1, lA2, uA1, uA2, A22, A12, A21, f11, f22, f21, f12, d11, d22, d21, d12, nenner, *SF; int result=1; SF = vector(L0); l1 = seLR_q_crit(l, L0, alpha/2., ur, hs, sigma, df, N, qm, c_error, a_error); l2 = l1 - .05; u1 = seU_q_crit(l, L0, alpha/2., hs, sigma, df, N, qm, c_error, a_error); u2 = u1 + .05; result = seLR_sf(l, l2, ur, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); lA2 = 1. - SF[L0-1]; result = seU_sf(l, u2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); uA2 = 1. - SF[L0-1]; result = se2_sf(l, l2, u2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); A22 = 1. - SF[L0-1]; do { result = seLR_sf(l, l1, ur, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); lA1 = 1. - SF[L0-1]; result = seU_sf(l, u1, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); uA1 = 1. - SF[L0-1]; result = se2_sf(l, l1, u2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); A12 = 1. - SF[L0-1]; result = se2_sf(l, l2, u1, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); A21 = 1. - SF[L0-1]; /* difference quotient */ f11 = (A22 - A12)/(l2-l1); f12 = (A22 - A21)/(u2-u1); f21 = (lA2 - lA1)/(l2-l1); f22 = (uA1 - uA2)/(u2-u1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dl = d11*(A22-alpha) + d12*(lA2-uA2); du = d21*(A22-alpha) + d22*(lA2-uA2); l1 = l2; u1 = u2; l2 -= dl; u2 -= du; result = seLR_sf(l, l2, ur, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); lA2 = 1. - SF[L0-1]; result = seU_sf(l, u2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); uA2 = 1. - SF[L0-1]; result = se2_sf(l, l2, u2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); A22 = 1. - SF[L0-1]; } while ( (fabs(alpha-A22)>1e-9 || fabs(lA2-uA2)>1e-9) && (fabs(l2-l1)>1e-9 || fabs(u2-u1)>1e-9) ); *cl = l2; *cu = u2; Free(SF); return 0; } int se2_q_crit_prerun_SIGMA(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error) { double s1, s2, s3, ds, sl1, sl2, sl3, csl, Pm, Pp, *SF; int result=1; SF = vector(L0); s1 = seU_q_crit_prerun_SIGMA(l, L0, alpha, hs, sigma, df1, df2, N, qm1, qm2, truncate, tail_approx, c_error, a_error); csl = 0.; if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s1, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = seU_sf_prerun_SIGMA(l, s1, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pm = 1. - SF[L0-1]; if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s1, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = seU_sf_prerun_SIGMA(l, s1, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pp = 1. - SF[L0-1]; sl1 = ( Pp - Pm )/(2.*lmEPS); s2 = s1 + .05; csl = se2fu_q_crit_prerun_SIGMA(l, L0, alpha, s2, hs, sigma, df1, df2, N, qm1, qm2, truncate, tail_approx, c_error, a_error); if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s2, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, csl, s2, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pm = 1. - SF[L0-1]; if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s2, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, csl, s2, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pp = 1. - SF[L0-1]; sl2 = ( Pp - Pm )/(2.*lmEPS); do { s3 = s1 - sl1/(sl2-sl1) * (s2-s1); csl = se2fu_q_crit_prerun_SIGMA(l, L0, alpha, s3, hs, sigma, df1, df2, N, qm1, qm2, truncate, tail_approx, c_error, a_error); if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s3, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, csl, s3, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pm = 1. - SF[L0-1]; if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s3, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, csl, s3, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pp = 1. - SF[L0-1]; sl3 = ( Pp - Pm )/(2.*lmEPS); ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; } while ( fabs(sl3)>a_error && fabs(ds)>c_error ); *cl = csl; *cu = s3; Free(SF); return 0; } double seUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm) { double *a, *g, *w, *z, *t, h, arl, Hij, xl, za, dN, ddf, s2, t0, t1, x0, x1, dummy; int i, j, k, qi, qj, M, Ntilde, NN, ii, it, jj; M = ceil( (log(cl)-log(cu))/log(1.-l) ); Ntilde = ceil( (double)N/(double)M ); NN = M*Ntilde; s2 = sigma*sigma; ddf = (double)df; dN = (double)Ntilde - 1.; a = matrix(NN,NN); g = vector(NN); t = vector(NN); w = vector(qm); z = vector(qm); for(i=0;icu) t1 = cu; for (j=1;j0) { qi = i-1; t0 = cl/pow(1.-l,(double)qi); t1 = t0/(1.-l); if (t1>cu) t1 = cu; if (t01e-10) x0 = sqrt(x0-za); else x0 = 0.; if (t1-za>1e-10) x1 = sqrt(t1-za); else x1 = 0.; } for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; if (j==1) a[ii*NN+jj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1); else { if (fabs(t1-x0)>1e-8) { gausslegendre(qm,x0,x1,z,w); Hij = 0.; for (k=0;kcu) t1 = cu; if (t01e-10) x0 = sqrt(x0-za); else x0 = 0.; if (t1-za>1e-10) x1 = sqrt(t1-za); else x1 = 0.; } if (i>0 && j==1 && qi==i) { for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1); } } if (i>0 && j==1 && qi>i) { for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = 0.; } } if (i==0 || j>1) { for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; gausslegendre(qm,x0,x1,z,w); Hij = 0.; for (k=0;kcu) t1 = cu; for (qj=1;qj<=Ntilde;qj++) { dummy = (cl-za)/l/s2; if (dummy>0.) { if (df==1) dummy = 2.*PHI( sqrt(dummy), 0. ) - 1.; if (df==2) dummy = 1. - exp( -dummy ); if (df>2) dummy = CHI( df*dummy, df); } else dummy = 0.; a[ii*NN+qj-1] -= dummy * Tn((2.*cl-t0-t1)/(t1-t0),qj-1); } } } } for (j=0;jcu) t1 = cu; if (t0<=hs && hscu ) t1 = cu; for (j=1; j0 ) { qi = i-1; t0 = cl/pow(1.-l,(double)qi); t1 = t0/(1.-l); if ( t1>cu ) t1 = cu; if ( t01e-8) { gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; kcu ) t1 = cu; if ( t00 && j==1 && qi==i ) { for (qj=1; qj<=Ntilde; qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1); } } if ( i>0 && j==1 && qi>i ) { for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = 0.; } } if ( i==0 || j>1 ) { for (qj=1; qj<=Ntilde; qj++) { jj = qi*Ntilde + qj-1; gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0;kcu ) t1 = cu; for (qj=1; qj<=Ntilde; qj++) { dummy = 0.; v = (cl-za)/l; if ( v>0. ) dummy = CHI(ddf/s2*v*v, df); a[ii*NN+qj-1] -= dummy * Tn((2.*cl-t0-t1)/(t1-t0),qj-1); } } } } for ( j=0; jcu ) t1 = cu; if ( t0<=hs && hs1)(zch[i,j]) */ for (i=0; i zreflect) */ for (i=0; i1)(zch[i,j]) */ for (i=0; i zreflect) */ for (i=0; i 1) { for (i=0; imn_plus ) mn_plus = q; } *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < FINALeps ) { *nstop = n; n = nmax + 1; } } /* n > 1 */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(S00); Free(p00); Free(VF0); return 0; } double seUR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0) { double *ww, *zz, b1, b2, ddf2, *SF, rho, s2; int i, m, n, nstop, Nlocal; Nlocal = choose_N_for_se2(l, cl, cu); SF = vector(nmax); ww = vector(qm2); zz = vector(qm2); ddf2 = (double)(df2); b1 = qCHI( truncate/2., df2)/ddf2; b2 = qCHI(1. - truncate/2., df2)/ddf2; gausslegendre(qm2, b1, b2, zz, ww); for (i=0; i 0 ) { for (n=0; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; s2 = zz[qnspecial-1]; j = seUR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 0 ) n--; if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.; } else { for (n=nn; n1)(zch[i,j]) */ for (i=0; i zreflect) */ for (i=0; i 1) { for (i=0; imn_plus ) mn_plus = q; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); /*if ( fabs( (q_plus-q_minus)/q_minus ) 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(p0); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(S00); Free(p00); Free(VF0); return Wq; } double seUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3; s2 = hs; do { s2 += .2; L2 = seUR_iglarl(l, cl, s2, hs, sigma, df, N, qm); } while (L21e-6 && fabs(ds)>1e-7 ); return s3; } double stdeUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3; s2 = hs; L2 = 0.; do { s1 = s2; L1 = L2; s2 += .2; L2 = stdeUR_iglarl(l, cl, s2, hs, sigma, df, N, qm); } while ( L21e-7 && fabs(ds)>1e-8 ); return s3; } double seUR_crit_prerun_SIGMA(double l, double L0, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate) { double s1, s2, s3, ds, L1=0., L2=0., L3=0.; s2 = hs; do { L1 = L2; s2 += .2; L2 = seUR_iglarl_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, N, qm1, qm2, truncate); } while ( L2 < L0 ); s1 = s2 - .2; do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = seUR_iglarl_prerun_SIGMA(l, cl, s3, hs, sigma, df1, df2, N, qm1, qm2, truncate); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-7 ); return s3; } double seUR_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = hs; p2 = 1.; do { p1 = p2; s2 += .2; result = seUR_sf(l, cl, s2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in seUR_q_crit [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha ); s1 = s2 - .2; do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); result = seUR_sf(l, cl, s3, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in seUR_q_crit [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double seUR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = seUR_q_crit(l, L0, alpha, cl, hs, sigma, df1, N, qm1, c_error, a_error); if ( tail_approx ) result = seUR_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seUR_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seUR_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; if ( p2 > alpha ) { do { p1 = p2; s2 += .2; if ( tail_approx ) result = seUR_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seUR_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seUR_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha ); s1 = s2 - .2; } else { do { p1 = p2; s2 -= .2; if ( tail_approx ) result = seUR_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seUR_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seUR_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 <= alpha && s2 > hs ); s1 = s2 + .2; } do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); if ( tail_approx ) result = seUR_sf_prerun_SIGMA_deluxe(l, cl, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seUR_sf_prerun_SIGMA(l, cl, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seUR_q_crit_prerun_SIGMA [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double seLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm) { double *a, *g, *w, *z, *t, h, arl, Hij, xl, za, dN, ddf, s2, t0, t1, x0, x1, dummy; int i, j, k, qi, qj, M, Ntilde, NN, ii, it, jj; M = ceil( (log(cl)-log(cu))/log(1.-l) ); Ntilde = ceil( (double)N/(double)M ); NN = M*Ntilde; s2 = sigma*sigma; ddf = (double)df; dN = (double)Ntilde - 1.; a = matrix(NN, NN); g = vector(NN); t = vector(NN); w = vector(qm); z = vector(qm); for(i=0;icu) t1 = cu; for (j=1;j0) { qi = i-1; t0 = cl/pow(1.-l,(double)qi); t1 = t0/(1.-l); if (t1>cu) t1 = cu; if (t01e-10) x0 = sqrt(x0-za); else x0 = 0.; if (t1-za>1e-10) x1 = sqrt(t1-za); else x1 = 0.; } for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; if (j==1) a[ii*NN+jj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1); else { if (fabs(t1-x0)>1e-8) { gausslegendre(qm,x0,x1,z,w); Hij = 0.; for (k=0;kcu) t1 = cu; if (t01e-10) x0 = sqrt(x0-za); else x0 = 0.; if (t1-za>1e-10) x1 = sqrt(t1-za); else x1 = 0.; } if (i>0 && j==1 && qi==i) { for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1); } } if (i>0 && j==1 && qi>i) { for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = 0.; } } if (i==0 || j>1) { for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; gausslegendre(qm,x0,x1,z,w); Hij = 0.; for (k=0;k1) { t0 = cl/pow(1.-l, (double)(M-1.)); t1 = cu; for (qj=1;qj<=Ntilde;qj++) { dummy = (cu-za)/l/s2; if (dummy>0.) { if (df==1) dummy = 2.*( 1. - PHI( sqrt(dummy), 0. ) ); if (df==2) dummy = exp( -dummy ); if (df>2) dummy = 1. - CHI( df*dummy, df); } else dummy = 0.; jj = (M-1)*Ntilde + qj-1; a[ii*NN+jj] -= dummy; } } } } for (j=0;jcu) t1 = cu; if (t0cu ) t1 = cu; for (j=1; j0 ) { qi = i-1; t0 = cl/pow(1.-l,(double)qi); t1 = t0/(1.-l); if ( t1>cu ) t1 = cu; if ( t01e-8 ) { gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; kcu ) t1 = cu; if ( t00 && j==1 && qi==i ) { for (qj=1; qj<=Ntilde; qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1); } } if ( i>0 && j==1 && qi>i ) { for (qj=1; qj<=Ntilde; qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = 0.; } } if ( i==0 || j>1 ) { for (qj=1; qj<=Ntilde; qj++) { jj = qi*Ntilde + qj-1; gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; k1 ) { t0 = cl/pow(1.-l, (double)(M-1.)); t1 = cu; for (qj=1; qj<=Ntilde; qj++) { dummy = 0.; v = (cu-za)/l; if ( v>0. ) dummy = 1. - CHI( ddf/s2*v*v, df); jj = (M-1)*Ntilde + qj-1; a[ii*NN+jj] -= dummy; } } } } for (j=0; jcu ) t1 = cu; if ( t0 10.*L0 ) { do { s1 = s2; L1 = L2; s2 -= .01; L2 = lns2ewmaU_arl_igl(l,cl,s2,hs,sigma,df,N); } while ( L2>L0 ); } do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = lns2ewmaU_arl_igl(l,cl,s3,hs,sigma,df,N); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-8 ); return s3; } double lns2ewma2_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N) { double *a, *g, *w, *z, arl, lns, ddf, s2; int i, j; s2 = sigma*sigma; ddf = (double)df; a = matrix(N,N); g = vector(N); w = vector(N); z = vector(N); gausslegendre(N, cl, cu, z, w); for (i=0; i 10.*L0 ) { do { s1 = s2; L1 = L2; s2 += .01; L2 = lns2ewma2_arl_igl(l,s2,cu,hs,sigma,df,N); } while ( L2>L0 ); } do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = lns2ewma2_arl_igl(l,s3,cu,hs,sigma,df,N); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-8 ); return s3; } int lns2ewma2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N) { double s1, s2, s3, ds, sl1, sl2, sl3, csl, Lm, Lp, mitte, ddf; ddf = (double)df; /*mitte = -1./ddf - 1./3./ddf/ddf + 2./15./ddf/ddf/ddf/ddf;*/ mitte = E_log_gamma(ddf); csl = lns2ewma2_crit_sym(l, L0, hs, sigma, df, N); s1 = 2.*mitte - csl; Lm = lns2ewma2_arl_igl(l,csl,s1,hs,sigma-lmEPS,df,N); Lp = lns2ewma2_arl_igl(l,csl,s1,hs,sigma+lmEPS,df,N); sl1 = (Lp-Lm)/(2.*lmEPS); do { s2 = s1; sl2 = sl1; s1 -= .1; csl = lns2ewma2_crit_cufix(l,s1,L0,hs,sigma,df,N); Lm = lns2ewma2_arl_igl(l,csl,s1,hs,sigma-lmEPS,df,N); Lp = lns2ewma2_arl_igl(l,csl,s1,hs,sigma+lmEPS,df,N); sl1 = (Lp-Lm)/(2.*lmEPS); } while ( sl1>0. ); do { s3 = s1 - sl1/(sl2-sl1) * (s2-s1); csl = lns2ewma2_crit_cufix(l,s3,L0,hs,sigma,df,N); Lm = lns2ewma2_arl_igl(l,csl,s3,hs,sigma-lmEPS,df,N); Lp = lns2ewma2_arl_igl(l,csl,s3,hs,sigma+lmEPS,df,N); sl3 = (Lp-Lm)/(2.*lmEPS); ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; } while ( fabs(sl3)>1e-7 && fabs(ds)>1e-8 ); *cl = csl; *cu = s3; return 0; } double lns2ewma2_crit_sym(double l, double L0, double hs, double sigma, int df, int N) { double cu, cl1, cl2, cl3, L1, L2, L3, dl, mitte, ddf; ddf = (double)df; /*mitte = -1./ddf - 1./3./ddf/ddf + 2./15./ddf/ddf/ddf/ddf;*/ mitte = E_log_gamma(ddf); L2 = 1.; cl2 = mitte; do { cl1 = cl2; L1 = L2; cl2 -= .1; cu = 2.*mitte - cl2; L2 = lns2ewma2_arl_igl(l, cl2, cu, hs, sigma, df, N); } while ( L21e-7) && (fabs(dl)>1e-8) ); return cl3; } double seLR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0) { double *S1s, *S2s, *Pns, *ws, *zs, *zch, *rside, *b, za=0., s2, ddf, xl, xu, dN, Hij, *S00, *p00, *VF0; int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj; M = ceil( (log(cl)-log(cu))/log(1.-l) ); Ntilde = ceil( (double)N/(double)M ); NN = M*Ntilde; s2 = sigma*sigma; ddf = (double)df; dN = (double)Ntilde; ihs = floor( (log(cl) - log(hs))/log(1.-l) ); if ( ihs<0 ) ihs = 0; S1s = matrix(NN,NN); S2s = matrix(NN,NN); ps = ivector(NN); zch = matrix(M,Ntilde); rside = vector(NN+1); b = vector(M+1); ws = vector(qm); zs = vector(qm); Pns = matrix(nmax,NN); S00 = vector(NN); p00 = vector(nmax); VF0 = vector(NN+1); /* interval borders b_i = cl/(1-l)^i */ for (i=0; i1)(zch[i,j]) */ for (i=0; i zreflect) */ for (i=0; i1)(zch[i,j]) */ for (i=0; i zreflect) */ for (i=0; i 1) { for (i=0; imn_plus ) mn_plus = q; } *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < FINALeps ) { *nstop = n; n = nmax + 1; } } /* n > 1 */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(S00); Free(p00); Free(VF0); return 0; } double seLR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0) { double *ww, *zz, b1, b2, ddf2, *SF, rho, s2; int i, m, n, nstop, Nlocal; Nlocal = choose_N_for_se2(l, cl, cu); SF = vector(nmax); ww = vector(qm2); zz = vector(qm2); ddf2 = (double)(df2); b1 = qCHI( truncate/2., df2)/ddf2; b2 = qCHI(1. - truncate/2., df2)/ddf2; gausslegendre(qm2, b1, b2, zz, ww); for (i=0; i 0 ) { for (n=0; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; s2 = zz[qnspecial-1]; j = seLR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 0 ) n--; if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.; } else { for (n=nn; n1)(zch[i,j]) */ for (i=0; i zreflect) */ for (i=0; i 1) { for (i=0; imn_plus ) mn_plus = q; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); /*if ( fabs( (q_plus-q_minus)/q_minus ) 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(p0); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(S00); Free(p00); Free(VF0); return Wq; } double seLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3; s2 = hs; L2 = 0.; do { s1 = s2; L1 = L2; s2 -= .1; L2 = seLR_iglarl(l, s2, cu, hs, sigma, df, N, qm); } while ( L20. ); do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = seLR_iglarl(l, s3, cu, hs, sigma, df, N, qm); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-7 && s3>0.); return s3; } double stdeLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3; s2 = hs; L2 = 0.; do { s1 = s2; L1 = L2; s2 -= .1; L2 = stdeLR_iglarl(l, s2, cu, hs, sigma, df, N, qm); } while ( L20. ); do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = stdeLR_iglarl(l, s3, cu, hs, sigma, df, N, qm); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-8 && s3>0.); return s3; } double seLR_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate) { double s1, s2, s3, ds, L1=0., L2=0., L3=0.; s2 = hs; do { L1 = L2; s2 -= .1; L2 = seLR_iglarl_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate); } while ( L2 < L0 && s2 > 0. ); s1 = s2 + .1; do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = seLR_iglarl_prerun_SIGMA(l, s3, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-7 && s3>0.); return s3; } double seLR_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = hs; p2 = 1.; do { p1 = p2; s2 -= .1; result = seLR_sf(l, s2, cu, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in seLR_q_crit [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha && s2>0.); s1 = s2 + .1; do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); result = seLR_sf(l, s3, cu, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in seLR_q_crit [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double seLR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = seLR_q_crit(l, L0, alpha, cu, hs, sigma, df1, N, qm1, c_error, a_error); if ( tail_approx ) result = seLR_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seLR_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seLR_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; if ( p2 > alpha ) { do { p1 = p2; s2 -= .1; if ( tail_approx ) result = seLR_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seLR_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seLR_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha && s2 > 0. ); s1 = s2 + .1; } else { do { p1 = p2; s2 += .1; if ( tail_approx ) result = seLR_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seLR_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seLR_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 <= alpha && s2 < hs ); s1 = s2 - .1; } do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); if ( tail_approx ) result = seLR_sf_prerun_SIGMA_deluxe(l, s3, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seLR_sf_prerun_SIGMA(l, s3, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seLR_q_crit_prerun_SIGMA [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } /* MEWMA: Rigdon (1995a,b) */ /* classical GL Nyström */ double mxewma_arl_0a(double lambda, double ce, int p, double hs, int N) { double *a, *g, *w, *z, arl, rr, r2; int i, j; a = matrix(N, N); g = vector(N); w = vector(N); z = vector(N); ce *= lambda/(2.-lambda); hs *= lambda/(2.-lambda); rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda); r2 = lambda*lambda; gausslegendre(N, 0., ce, z, w); for (i=0; i 1e-10 ) { arl = 1.; for (j=0; j 1e-10 ) { arl = 1.; for (j=0; j 1e-12) - (double)(x < -1e-12); return result; } /* collocation with two halfs in the same step + sin() */ double mxewma_arl_1b(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1) { double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, *g, dN, term1, term2, term2a, term2b, innen, arl, mean, sigma, eta, u, u2, uu, v, v2, alpha; int r, s, i, j, k, l, N2, N3, p1; N2 = N*N; N3 = N2*N; M = matrix(N2, N2); g = vector(N2); z0 = vector(qm0); w0 = vector(qm0); z1 = vector(qm1); w1 = vector(qm1); ce *= lambda/(2.-lambda); hs *= lambda/(2.-lambda); sigma = lambda/sqrt(ce); rdc = lambda*sqrt(delta/ce); r2 = lambda*lambda; rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda); dN = (double)N; p1 = p - 1; /* canonical Gauss-Legendre nodes and weights */ gausslegendre(qm0, 0., 1., z0, w0); gausslegendre(qm1, 0., 1., z1, w1); for (s=0; s 1. ) upper = 1.; /* substitution sin(alpha) = v */ lower = asin(lower); upper = asin(upper); /* constants for (-1,1) <-> (lower,upper) */ xm = (lower+upper)/2.; xw = (upper-lower)/2.; for (r=0; r 1. ) upper = 1.; /* substitution sin(alpha) = v */ lower = asin(lower); upper = asin(upper); /* constants for (-1,1) <-> (lower,upper) */ xm = (lower+upper)/2.; xw = (upper-lower)/2.; for (r=0; r1e-8 ) && ( fabs(dc)>1e-10) ); return c3; } double mxewma_psi (double lambda, double ce, int p, int N, double *PSI, double *w, double *z) { double *a, rr, r2, rho, norm; int i, j, status, noofit; a = matrix(N, N); ce *= lambda/(2.-lambda); rr = ( (1.-lambda)/lambda ) * ( (1.-lambda)/lambda ); r2 = lambda*lambda; gausslegendre(N, 0., sqrt(ce), z, w); for (i=0; i 1e-10 ) psi0 = 2.*hs * nchi(xi/r2, p, rr*hs*hs) / r2 / zahl; } for (j=0; j 1e-10 ) psi0 = 2.*hs * nchi(xi/r2, p, rr*hs*hs) / r2 / zahl; } for (j=0; j1)(zch[i]) */ for (i=0;i1) { for (i=0;imn_plusx ) mn_plusx = q; } for (i=0;imn_pluss ) mn_pluss = q; } mn_minus = mn_minusx * mn_minuss; mn_plus = mn_plusx * mn_pluss; arl_minus = arl + p0[n-1]/(1.-mn_minus); arl_plus = arl + p0[n-1]/(1.-mn_plus); } arl += p0[n-1]; if ( fabs( (arl_plus-arl_minus)/arl_minus )1)(zch[i]) */ for (i=0;i1)(zch[i]) */ for (i=0;i 1 ) { for (i=0;imn_plusx ) mn_plusx = q; } for (i=0;imn_pluss ) mn_pluss = q; } mn_minus = mn_minusx * mn_minuss; mn_plus = mn_plusx * mn_pluss; *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < FINALeps ) { *nstop = n; n = nmax + 1; } } /* n > 1 */ } /* n=1; n<=nmax; n++ */ Free(p0s); Free(Pns); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(p0x); Free(Pnx); Free(zx); Free(wx); Free(Sx); return 0; } double xseU_Wq(double lx, double ls, double cx, double cs, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm) { double *p0, *Sx, *Pnx, *wx, *zx, *p0x, *S1s, *S2s, *Pns, *ws, *zs, *p0s, q, *zch, *rside, za=0., s2, mn_minus=1., mn_plus=0., mn_minusx, mn_minuss, mn_plusx, mn_pluss, ddf, xl, xu, oben, unten, q_minus=0., q_plus=0., enumerator=0., Wq=0.; int i, j, k, n, *ps; cx *= sqrt( lx/(2.-lx) ); hsx *= sqrt( lx/(2.-lx) ); s2 = sigma*sigma; ddf = (double)df; Sx = matrix(Nx,Nx); wx = vector(Nx); zx = vector(Nx); Pnx = matrix(nmax,Nx); p0x = vector(nmax); S1s = matrix(Ns,Ns); S2s = matrix(Ns,Ns); ps = ivector(Ns); zch = vector(Ns); rside = vector(Ns); ws = vector(qm); zs = vector(qm); Pns = matrix(nmax,Ns); p0s = vector(nmax); p0 = vector(nmax); gausslegendre(Nx,-cx,cx,zx,wx); for (i=0;i1)(zch[i]) */ for (i=0;i 1 ) { for (i=0;imn_plusx ) mn_plusx = q; } for (i=0;imn_pluss ) mn_pluss = q; } mn_minus = mn_minusx * mn_minuss; mn_plus = mn_plusx * mn_pluss; enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(p0); Free(p0s); Free(Pns); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(p0x); Free(Pnx); Free(zx); Free(wx); Free(Sx); return Wq; } int xseU_crit(double lx, double ls, double L0, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm) { double x1, x2, dx, s1, s2, ds, xARL1, xARL2, sARL1, sARL2, xsARL22, xsARL12, xsARL21, f11, f22, f21, f12, d11, d22, d21, d12, nenner, zr=0., c0=-1.; x1 = xe_crit(ewma2,lx,2.*L0,zr,hsx,mu,fix,Nx,c0) - .1; x2 = x1 + .1; s1 = seU_crit(ls,2.*L0,hss,sigma,df,Ns,qm); s2 = s1 + .05; xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx); sARL2 = seU_iglarl(ls,s2,hss,sigma,df,Ns,qm); xsARL22 = xseU_arl(lx,ls,x2,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); do { xARL1 = xe2_iglarl(lx,x1,hsx,mu,Nx); sARL1 = seU_iglarl(ls,s1,hss,sigma,df,Ns,qm); xsARL21 = xseU_arl(lx,ls,x2,s1,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); xsARL12 = xseU_arl(lx,ls,x1,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); /* difference quotient */ f11 = (xsARL22 - xsARL12)/(x2-x1); f12 = (xsARL22 - xsARL21)/(s2-s1); f21 = (xARL2 - xARL1)/(x2-x1); f22 = (sARL1 - sARL2)/(s2-s1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dx = d11*(xsARL22-L0) + d12*(xARL2-sARL2); ds = d21*(xsARL22-L0) + d22*(xARL2-sARL2); x1 = x2; s1 = s2; x2 -= dx; s2 -= ds; xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx); sARL2 = seU_iglarl(ls,s2,hss,sigma,df,Ns,qm); xsARL22 = xseU_arl(lx,ls,x2,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); } while ( (fabs(L0-xsARL22)>1e-6 || fabs(xARL2-sARL2)>1e-6) && (fabs(x2-x1)>1e-8 || fabs(s2-s1)>1e-8) ); *cx = x2; *cs = s2; return 0; } int xseU_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error) { double x1, x2, dx, s1, s2, ds, xp1, xp2, sp1, sp2, xsp22, xsp12, xsp21, f11, f22, f21, f12, d11, d22, d21, d12, nenner, zr=0., *SF; int result=1; SF = vector(L0); x1 = xe_q_crit(ewma2, lx, L0, 1. - sqrt(1.-alpha), zr, hsx, mu, fix, Nx, c_error, a_error); x2 = x1 + .1; s1 = seU_q_crit(ls, L0, 1. - sqrt(1.-alpha), hss, sigma, df, Ns, qm, c_error, a_error); s2 = s1 + .05; result = xe2_sf(lx, x2, hsx, mu, Nx, L0, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling xe2_sf [package spc]"); xp2 = 1. - SF[L0-1]; result = seU_sf(ls, s2, hss, sigma, df, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling seU_sf [package spc]"); sp2 = 1. - SF[L0-1]; result = xseU_sf(lx, ls, x2, s2, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling xseU_sf [package spc]"); xsp22 = 1. - SF[L0-1]; do { result = xe2_sf(lx, x1, hsx, mu, Nx, L0, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling xe2_sf [package spc]"); xp1 = 1. - SF[L0-1]; result = seU_sf(ls, s1, hss, sigma, df, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling seU_sf [package spc]"); sp1 = 1. - SF[L0-1]; result = xseU_sf(lx, ls, x2, s1, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling xseU_sf [package spc]"); xsp21 = 1. - SF[L0-1]; result = xseU_sf(lx, ls, x1, s2, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling xseU_sf [package spc]"); xsp12 = 1. - SF[L0-1]; /* difference quotient */ f11 = (xsp22 - xsp12)/(x2-x1); f12 = (xsp22 - xsp21)/(s2-s1); f21 = (xp2 - xp1)/(x2-x1); f22 = (sp1 - sp2)/(s2-s1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dx = d11*(xsp22-alpha) + d12*(xp2-sp2); ds = d21*(xsp22-alpha) + d22*(xp2-sp2); x1 = x2; s1 = s2; x2 -= dx; s2 -= ds; result = xe2_sf(lx, x2, hsx, mu, Nx, L0, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling xe2_sf [package spc]"); xp2 = 1. - SF[L0-1]; result = seU_sf(ls, s2, hss, sigma, df, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling seU_sf [package spc]"); sp2 = 1. - SF[L0-1]; result = xseU_sf(lx, ls, x2, s2, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling xseU_sf [package spc]"); xsp22 = 1. - SF[L0-1]; } while ( (fabs(alpha - xsp22)>a_error || fabs(xp2-sp2)>a_error) && (fabs(x2-x1)>c_error || fabs(s2-s1)>c_error) ); *cx = x2; *cs = s2; Free(SF); return 0; } int xse2fu_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error) { double x1, x2, dx, s1, s2, ds, xp1, xp2, sp1, sp2, xsp22, xsp12, xsp21, f11, f22, f21, f12, d11, d22, d21, d12, nenner, zr=0., *SF; int result=1; SF = vector(L0); x1 = xe_q_crit(ewma2, lx, L0, 1. - sqrt(1.-alpha), zr, hsx, mu, fix, Nx, c_error, a_error); x2 = x1 + .05; s1 = se2fu_q_crit(ls, L0, 1. - sqrt(1.-alpha), csu, hss, sigma, df, Ns, qm, c_error, a_error); s2 = s1 + .05; result = xe2_sf(lx, x2, hsx, mu, Nx, L0, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xe2_sf [package spc]"); xp2 = 1. - SF[L0-1]; result = se2_sf(ls, s2, csu, hss, sigma, df, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling se2_sf [package spc]"); sp2 = 1. - SF[L0-1]; result = xse2_sf(lx, ls, x2, s2, csu, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xse2_sf [package spc]"); xsp22 = 1. - SF[L0-1]; do { result = xe2_sf(lx, x1, hsx, mu, Nx, L0, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xe2_sf [package spc]"); xp1 = 1. - SF[L0-1]; result = se2_sf(ls, s1, csu, hss, sigma, df, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling se2_sf [package spc]"); sp1 = 1. - SF[L0-1]; result = xse2_sf(lx, ls, x2, s1, csu, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xse2_sf [package spc]"); xsp21 = 1. - SF[L0-1]; result = xse2_sf(lx, ls, x1, s2, csu, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xse2_sf [package spc]"); xsp12 = 1. - SF[L0-1]; /* difference quotient */ f11 = (xsp22 - xsp12)/(x2-x1); f12 = (xsp22 - xsp21)/(s2-s1); f21 = (xp2 - xp1)/(x2-x1); f22 = (sp1 - sp2)/(s2-s1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dx = d11*(xsp22-alpha) + d12*(xp2-sp2); ds = d21*(xsp22-alpha) + d22*(xp2-sp2); x1 = x2; s1 = s2; x2 -= dx; s2 -= ds; result = xe2_sf(lx, x2, hsx, mu, Nx, L0, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xe2_sf [package spc]"); xp2 = 1. - SF[L0-1]; result = se2_sf(ls, s2, csu, hss, sigma, df, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling se2_sf [package spc]"); sp2 = 1. - SF[L0-1]; result = xse2_sf(lx, ls, x2, s2, csu, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xse2_sf [package spc]"); xsp22 = 1. - SF[L0-1]; } while ( (fabs(alpha - xsp22)>a_error || fabs(xp2-sp2)>a_error) && (fabs(x2-x1)>c_error || fabs(s2-s1)>c_error) ); *cx = x2; *csl = s2; Free(SF); return 0; } int xse2_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error) { double s1, s2, s3, ds, sl1, sl2, sl3, Lm, Lp, x, cl, *SF; int result=1; SF = vector(L0); cl = 0.; result = xseU_q_crit(lx, ls, L0, alpha, &x, &s1, hsx, hss, mu, sigma, df, Nx, Ns, qm, c_error, a_error); if ( result != 0 ) warning("trouble with xse2_q_crit calling xseU_q_crit [package spc]"); result = xseU_sf(lx, ls, x, s1, hsx, hss, mu, sigma-lmEPS, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2_q_crit calling xseU_sf [package spc]"); Lm = 1. - SF[L0-1]; result = xseU_sf(lx, ls, x, s1, hsx, hss, mu, sigma+lmEPS, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2_q_crit calling xseU_sf [package spc]"); Lp = 1. - SF[L0-1]; sl1 = (Lp-Lm)/(2.*lmEPS); s2 = s1 + .15; result = xse2fu_q_crit(lx, ls, L0, alpha, &x, &cl, s2, hsx, hss, mu, sigma, df, Nx, Ns, qm, c_error, a_error); if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2fu_q_crit [package spc]"); result = xse2_sf(lx, ls, x, cl, s2, hsx, hss, mu, sigma-lmEPS, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2_sf [package spc]"); Lm = 1. - SF[L0-1]; result = xse2_sf(lx, ls, x, cl, s2, hsx, hss, mu, sigma+lmEPS, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2_sf [package spc]"); Lp = 1. - SF[L0-1]; sl2 = (Lp-Lm)/(2.*lmEPS); do { s3 = s1 - sl1/(sl2-sl1) * (s2-s1); result = xse2fu_q_crit(lx, ls, L0, alpha, &x, &cl, s3, hsx, hss, mu, sigma, df, Nx, Ns, qm, c_error, a_error); if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2fu_q_crit [package spc]"); result = xse2_sf(lx, ls, x, cl, s3, hsx, hss, mu, sigma-lmEPS, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2_sf [package spc]"); Lm = 1. - SF[L0-1]; result = xse2_sf(lx, ls, x, cl, s3, hsx, hss, mu, sigma+lmEPS, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2_sf [package spc]"); Lp = 1. - SF[L0-1]; sl3 = (Lp-Lm)/(2.*lmEPS); ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; } while ( fabs(sl3)>a_error && fabs(ds)>c_error ); *cx = x; *csl = cl; *csu = s3; Free(SF); return 0; } double xse2_arl(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm) { double *Sx, *Pnx, *wx, *zx, *p0x, *p0, *S1s, *S2s, *Pns, *ws, *zs, *p0s, q, *zch, *rside, *b, za=0., s2, dN, Hij, arl_minus=0., arl, arl_plus=0., mn_minus=1., mn_plus=0., mn_minusx, mn_minuss, mn_plusx, mn_pluss, ddf, xl, xu, oben, unten; int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj; cx *= sqrt( lx/(2.-lx) ); hsx *= sqrt( lx/(2.-lx) ); M = ceil( (log(csl)-log(csu))/log(1.-ls) ); Ntilde = ceil( (double)Ns/(double)M ); NN = M*Ntilde; s2 = sigma*sigma; ddf = (double)df; dN = (double)Ntilde; ihs = floor( (log(csl)-log(hss))/log(1.-ls) ); if (ihs<0) ihs = 0; Sx = matrix(Nx,Nx); wx = vector(Nx); zx = vector(Nx); Pnx = matrix(nmax,Nx); p0x = vector(nmax); S1s = matrix(NN,NN); S2s = matrix(NN,NN); ps = ivector(NN); zch = matrix(M,Ntilde); rside = vector(NN); b = vector(M+1); ws = vector(qm); zs = vector(qm); Pns = matrix(nmax,NN); p0s = vector(nmax); p0 = vector(nmax); gausslegendre(Nx,-cx,cx,zx,wx); for (i=0;i1)(zch[i,j]) */ for (i=0;i1) { for (i=0;imn_plusx ) mn_plusx = q; } for (i=0;imn_pluss ) mn_pluss = q; } mn_minus = mn_minusx * mn_minuss; mn_plus = mn_plusx * mn_pluss; arl_minus = arl + p0[n-1]/(1.-mn_minus); arl_plus = arl + p0[n-1]/(1.-mn_plus); } arl += p0[n-1]; if ( fabs( (arl_plus-arl_minus)/arl_minus )1)(zch[i,j]) */ for (i=0;i1)(zch[i,j]) */ for (i=0;i1 ) { for (i=0;imn_plusx ) mn_plusx = q; } for (i=0;imn_pluss ) mn_pluss = q; } mn_minus = mn_minusx * mn_minuss; mn_plus = mn_plusx * mn_pluss; *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < FINALeps ) { *nstop = n; n = nmax + 1; } } /* n > 1 */ } /* n=1; n<=nmax; n++ */ Free(p0s); Free(Pns); Free(zs); Free(ws); Free(b); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(p0x); Free(Pnx); Free(zx); Free(wx); Free(Sx); return 0; } double xse2_Wq(double lx, double ls, double cx, double csl, double csu, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm) { double *p0, *Sx, *Pnx, *wx, *zx, *p0x, *S1s, *S2s, *Pns, *ws, *zs, *p0s, q, *zch, *rside, *b, za=0., s2, dN, Hij, mn_minus=1., mn_plus=0., mn_minusx, mn_minuss, mn_plusx, mn_pluss, ddf, xl, xu, oben, unten, q_minus=0., q_plus=0., enumerator=0., Wq=0.; int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj; cx *= sqrt( lx/(2.-lx) ); hsx *= sqrt( lx/(2.-lx) ); M = ceil( (log(csl)-log(csu))/log(1.-ls) ); Ntilde = ceil( (double)Ns/(double)M ); NN = M*Ntilde; s2 = sigma*sigma; ddf = (double)df; dN = (double)Ntilde; ihs = floor( (log(csl)-log(hss))/log(1.-ls) ); if (ihs<0) ihs = 0; Sx = matrix(Nx,Nx); wx = vector(Nx); zx = vector(Nx); Pnx = matrix(nmax,Nx); p0x = vector(nmax); S1s = matrix(NN,NN); S2s = matrix(NN,NN); ps = ivector(NN); zch = matrix(M,Ntilde); rside = vector(NN); b = vector(M+1); ws = vector(qm); zs = vector(qm); Pns = matrix(nmax,NN); p0s = vector(nmax); p0 = vector(nmax); gausslegendre(Nx,-cx,cx,zx,wx); for (i=0;i1)(zch[i,j]) */ for (i=0;i1 ) { for (i=0;imn_plusx ) mn_plusx = q; } for (i=0;imn_pluss ) mn_pluss = q; } mn_minus = mn_minusx * mn_minuss; mn_plus = mn_plusx * mn_pluss; enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(p0); Free(p0s); Free(Pns); Free(zs); Free(ws); Free(b); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(p0x); Free(Pnx); Free(zx); Free(wx); Free(Sx); return Wq; } int xse2lu_crit(double lx, double ls, double L0, double *cx, double csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm) { double x1, x2, dx, s1, s2, ds, xARL1, xARL2, sARL1, sARL2, xsARL22, xsARL12, xsARL21, f11, f22, f21, f12, d11, d22, d21, d12, nenner, zr=0, c0=-1.; x1 = xe_crit(ewma2,lx,2.*L0,zr,hsx,mu,fix,Nx,c0) - .1; x2 = x1 + .2; s1 = se2lu_crit(ls,2.*L0,csl,hss,sigma,df,Ns,qm) - .1; s2 = s1 + .2; xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx); sARL2 = se2_iglarl(ls,csl,s2,hss,sigma,df,Ns,qm); xsARL22 = xse2_arl(lx,ls,x2,csl,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); do { xARL1 = xe2_iglarl(lx,x1,hsx,mu,Nx); sARL1 = se2_iglarl(ls,csl,s1,hss,sigma,df,Ns,qm); xsARL21 = xse2_arl(lx,ls,x2,csl,s1,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); xsARL12 = xse2_arl(lx,ls,x1,csl,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); /* difference quotient */ f11 = (xsARL22 - xsARL12)/(x2-x1); f12 = (xsARL22 - xsARL21)/(s2-s1); f21 = (xARL2 - xARL1)/(x2-x1); f22 = (sARL1 - sARL2)/(s2-s1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dx = d11*(xsARL22-L0) + d12*(xARL2-sARL2); ds = d21*(xsARL22-L0) + d22*(xARL2-sARL2); x1 = x2; s1 = s2; x2 -= dx; s2 -= ds; xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx); sARL2 = se2_iglarl(ls,csl,s2,hss,sigma,df,Ns,qm); xsARL22 = xse2_arl(lx,ls,x2,csl,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); } while ( (fabs(L0-xsARL22)>1e-6 || fabs(xARL2-sARL2)>1e-6) && (fabs(x2-x1)>1e-7 || fabs(s2-s1)>1e-7) ); *cx = x2; *csu = s2; return 0; } int xse2fu_crit(double lx, double ls, double L0, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm) { double x1, x2, dx, s1, s2, ds, xARL1, xARL2, sARL1, sARL2, xsARL22, xsARL12, xsARL21, f11, f22, f21, f12, d11, d22, d21, d12, nenner, zr=0, c0=-1.; x1 = xe_crit(ewma2,lx,2.*L0,zr,hsx,mu,fix,Nx,c0) - .1; x2 = x1 + .2; s1 = se2fu_crit(ls,2.*L0,csu,hss,sigma,df,Ns,qm) - .1; s2 = s1 + .2; xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx); sARL2 = se2_iglarl(ls,s2,csu,hss,sigma,df,Ns,qm); xsARL22 = xse2_arl(lx,ls,x2,s2,csu,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); /*printf("cx = %.4f,\tcsk = %.4f,\tcsu = %.4f\t,\txARL = %.2f,\tsARL = %.2f,\txsARL = %.2f\n", x2, s2, csu, xARL2, sARL2, xsARL22);*/ do { xARL1 = xe2_iglarl(lx,x1,hsx,mu,Nx); sARL1 = se2_iglarl(ls,s1,csu,hss,sigma,df,Ns,qm); xsARL21 = xse2_arl(lx,ls,x2,s1,csu,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); xsARL12 = xse2_arl(lx,ls,x1,s2,csu,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); /* difference quotient */ f11 = (xsARL22 - xsARL12)/(x2-x1); f12 = (xsARL22 - xsARL21)/(s2-s1); f21 = (xARL2 - xARL1)/(x2-x1); f22 = (sARL1 - sARL2)/(s2-s1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dx = d11*(xsARL22-L0) + d12*(xARL2-sARL2); ds = d21*(xsARL22-L0) + d22*(xARL2-sARL2); x1 = x2; s1 = s2; x2 -= dx; s2 -= ds; xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx); sARL2 = se2_iglarl(ls,s2,csu,hss,sigma,df,Ns,qm); xsARL22 = xse2_arl(lx,ls,x2,s2,csu,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); /*printf("cx = %.4f,\tcsk = %.4f,\tcsu = %.4f\t,\txARL = %.2f,\tsARL = %.2f,\txsARL = %.2f\n", x2, s2, csu, xARL2, sARL2, xsARL22);*/ } while ( (fabs(L0-xsARL22)>1e-6 || fabs(xARL2-sARL2)>1e-6) && (fabs(x2-x1)>1e-8 || fabs(s2-s1)>1e-8) ); *cx = x2; *csl = s2; return 0; } int xse2_crit(double lx, double ls, double L0, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm) { double s1, s2, s3, ds, sl1, sl2, sl3, Lm, Lp, x, cl; int flag; cl = 0.; flag = xseU_crit(lx,ls,L0,&x,&s1,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); /*printf("cx = %.4f,\tcsl = %.4f,\tcsu = %.4f\n", x, cl, s1);*/ Lm = xseU_arl(lx,ls,x,s1,hsx,hss,mu,sigma-lmEPS,df,Nx,Ns,nmax,qm); Lp = xseU_arl(lx,ls,x,s1,hsx,hss,mu,sigma+lmEPS,df,Nx,Ns,nmax,qm); sl1 = (Lp-Lm)/(2.*lmEPS); s2 = s1 + .15; flag = xse2fu_crit(lx,ls,L0,&x,&cl,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); /*printf("cx = %.4f,\tcsl = %.4f,\tcsu = %.4f\n", x, cl, s2);*/ Lm = xse2_arl(lx,ls,x,cl,s2,hsx,hss,mu,sigma-lmEPS,df,Nx,Ns,nmax,qm); Lp = xse2_arl(lx,ls,x,cl,s2,hsx,hss,mu,sigma+lmEPS,df,Nx,Ns,nmax,qm); sl2 = (Lp-Lm)/(2.*lmEPS); do { s3 = s1 - sl1/(sl2-sl1) * (s2-s1); flag = xse2fu_crit(lx,ls,L0,&x,&cl,s3,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); Lm = xse2_arl(lx,ls,x,cl,s3,hsx,hss,mu,sigma-lmEPS,df,Nx,Ns,nmax,qm); Lp = xse2_arl(lx,ls,x,cl,s3,hsx,hss,mu,sigma+lmEPS,df,Nx,Ns,nmax,qm); sl3 = (Lp-Lm)/(2.*lmEPS); /*printf("cx = %.4f,\tcsl = %.4f,\tcsu = %.4f\t,\tslope = %.6f\n", x, cl, s3, sl3);*/ ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; } while ( fabs(sl3)>1e-6 && fabs(ds)>1e-7 ); *cx = x; *csl = cl; *csu = s3; return flag; } /* EWMA p under sampling by variables */ /* p = h(mu, sigma) */ double WK_h(double mu, double sigma, double LSL, double USL) { double result; result = PHI( (LSL-mu)/sigma, 0.) + PHI( (mu-USL)/sigma, 0.); return result; } /* d/dmu h(mu, sigma) */ double wk_h_mu(double mu, double sigma, double LSL, double USL) { double result; result = ( -phi( (LSL-mu)/sigma, 0.) + phi( (mu-USL)/sigma, 0.) )/sigma; return result; } /* d/dsigma h(mu, sigma) */ double wk_h_sigma(double mu, double sigma, double LSL, double USL) { double result; result = -( (LSL-mu)*phi( (LSL-mu)/sigma, 0.) + (mu-USL)*phi( (mu-USL)/sigma, 0.) )/sigma/sigma; return result; } /* mu = h^-1(p, sigma) */ double WK_h_invers_mu(double p, double sigma, double LSL, double USL) { double mu, old_mu, merror, perror; mu = sigma*qPHI(p) + USL; perror = WK_h(mu, sigma, LSL, USL) - p; do { old_mu = mu; mu = mu - perror / wk_h_mu(mu, sigma, LSL, USL); merror = mu - old_mu; perror = WK_h(mu, sigma, LSL, USL) - p; } while ( fabs(merror) > 1e-10 && fabs(perror) > 1e-12 ); return mu; } /* sigma = h^-1(p, mu) */ double WK_h_invers_sigma(double p, double mu, double LSL, double USL) { double sigma, old_sigma, serror, perror; sigma = (mu-USL)/qPHI(p); perror = WK_h(mu, sigma, LSL, USL) - p; do { old_sigma = sigma; sigma = sigma - perror / wk_h_sigma(mu, sigma, LSL, USL); serror = sigma - old_sigma; perror = WK_h(mu, sigma, LSL, USL) - p; } while ( fabs(serror) > 1e-10 && fabs(perror) > 1e-12 ); return sigma; } /* alpha, the upper limit of the cdf (and pdf) definite integral */ double wk_alpha(double p, double sigma, int n, double LSL, double USL) { double alpha, dn, zphalf; dn = (double)n; zphalf = qPHI(p/2.); alpha = (dn-1.)/sigma/sigma * (USL-LSL)*(USL-LSL)/4. / (zphalf*zphalf); return alpha; } /* cdf of h(xbar, sigma0=1) for X ~ N(mu, sigma) */ double cdf_phat(double p, double mu, double sigma, int n, double LSL, double USL) { double result, pstar, mu_of_p, dn, centre; dn = (double)n; result = 0.; if ( p >= 1. ) result = 1.; centre = (LSL+USL)/2.; /*pstar = WK_h(centre, sigma, LSL, USL);*/ pstar = WK_h(centre, 1., LSL, USL); if ( pstar < p && p < 1. ) { mu_of_p = WK_h_invers_mu(p, 1., LSL, USL); result = PHI( (mu_of_p - mu)*sqrt(dn)/sigma, 0. ) - PHI( (-mu_of_p - mu)*sqrt(dn)/sigma, 0. ); } return result; } /* pdf of h(xbar, sigma0=1) for X ~ N(mu, sigma) */ double pdf_phat(double p, double mu, double sigma, int n, double LSL, double USL) { double result, pstar, mu_of_p, dn, centre; dn = (double)n; result = 0.; centre = (LSL+USL)/2.; /*pstar = WK_h(centre, sigma, LSL, USL);*/ pstar = WK_h(centre, 1., LSL, USL); if ( pstar < p && p < 1. ) { mu_of_p = WK_h_invers_mu(p, 1., LSL, USL); result = sqrt(dn)*( phi( (mu_of_p - mu)*sqrt(dn)/sigma, 0. ) + phi( (-mu_of_p - mu)*sqrt(dn)/sigma, 0. ) ) / wk_h_mu(mu_of_p, 1., LSL, USL)/sigma; } return result; } /* quantile function of h(xbar, sigma0=1) for X ~ N(mu, sigma) */ double qf_phat(double p0, double mu, double sigma, int n, double LSL, double USL) { double pstar, centre, c1, c2, c3, p1, p2, p3, dc, cstep; centre = (LSL+USL)/2.; pstar = WK_h(centre, sigma, LSL, USL); c2 = pstar; p2 = 0.; cstep = p0/1e3; do { c1 = c2; p1 = p2; c2 += cstep; p2 = cdf_phat(c2, mu, sigma, n, LSL, USL); } while ( p2 < p0 ); if ( c2 <= pstar + cstep + 1e-9 ) { c1 = c2 - cstep/2.; p1 = cdf_phat(c1, mu, sigma, n, LSL, USL); } do { c3 = c1 + ( p0 - p1 )/( p2 - p1 ) * ( c2 - c1 ); p3 = cdf_phat(c3, mu, sigma, n, LSL, USL); dc = c3 - c2; c1 = c2; p1 = p2; c2 = c3; p2 = p3; } while ( fabs( p0 - p3 )>1e-10 && fabs(dc)>1e-10 ); return c3; } /* integrand for cdf of h(xbar, s) for X ~ N(mu, sigma) */ double wk_cdf_i(double y, double p, double mu, double sigma, int n, double LSL, double USL) { double result, alpha, x, s, mu_p, dn, atrim; dn = (double)n; alpha = wk_alpha(p, sigma, n, LSL, USL); atrim = qCHI(0.9999999999, n-1); if ( atrim < alpha ) alpha = atrim; x = alpha - pow(y,2.); s = sigma * sqrt( x/(dn-1.) ); mu_p = WK_h_invers_mu(p, s, LSL, USL); result = PHI( (mu_p-mu)*sqrt(dn)/sigma, 0.) - PHI( (-mu_p-mu)*sqrt(dn)/sigma, 0.); result *= chi(x, n-1) * 2*y; return result; } /* cdf of h(xbar, s) for X ~ N(mu, sigma) */ double cdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes) { double result, alpha, *w, *z, xl, xu, atrim; int i; w = vector(nodes); z = vector(nodes); result = 0.; if ( p >= 1. ) result = 1.; xl = 0.; if ( 0. < p && p < 1. ) { alpha = wk_alpha(p, sigma, n, LSL, USL); atrim = qCHI(0.9999999999, n-1); if ( atrim < alpha ) alpha = atrim; xu = pow(alpha,0.5); gausslegendre(nodes, xl, xu, z, w); for (i=0; i1e-10 && fabs(dc)>1e-10 ); return c3; } /* collocation */ double ewma_phat_arl(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm) { double *a, *g, *w, *z, arl, Hij, dN, xl, xu, za, ll, pstar, xi, centre; int i, j, k; dN = (double)N; a = matrix(N,N); g = vector(N); w = vector(qm); z = vector(qm); centre = (LSL+USL)/2.; /*pstar = WK_h(centre, sigma, LSL, USL);*/ pstar = WK_h(centre, 1., LSL, USL); for (i=0; i1e-6 && fabs(dc)>1e-12 ); return c3; } double ewma_phat_crit2(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M) { double c1, c2, c3, L1, L2, L3, dc, cstep; c2 = 0.; L2 = 0.; cstep = lambda/10.; do { c1 = c2; L1 = L2; c2 += cstep; L2 = ewma_phat_arl2(lambda, c2, mu, sigma, n, z0, LSL, USL, N, qm, M); } while ( L2 < L0 ); if ( c2 <= cstep + 1e-9 ) { c1 = c2 - cstep/2.; L1 = ewma_phat_arl2(lambda, c1, mu, sigma, n, z0, LSL, USL, N, qm, M); } do { c3 = c1 + ( L0 - L1 )/( L2 - L1 ) * ( c2 - c1 ); L3 = ewma_phat_arl2(lambda, c3, mu, sigma, n, z0, LSL, USL, N, qm, M); dc = c3 - c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3; } while ( fabs( L0 - L3 )>1e-6 && fabs(dc)>1e-12 ); return c3; } int N_of_l(double lambda) { int N; N = 20; if ( lambda < 1e-1 ) N = 40; if ( lambda < 1e-2 ) N = 60; if ( lambda < 1e-3 ) N = 120; if ( lambda < 1e-4 ) N = 200; return N; } double ewma_phat_lambda(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm) { double dn, cS, cE, ldelta, one, L1, L1_, lambda; int i, j, N; lambda = 1.; dn = (double)n; cS = qPHI( 1. - 1./(2.*L0) )/sqrt(dn)*sigma; cE = WK_h( cS, 1., LSL, USL ); L1 = 1./( PHI( (-cS-mu)*sqrt(dn)/sigma, 0.) + 1. - PHI( (cS-mu)*sqrt(dn)/sigma, 0.) ); ldelta = .1; one = 1; for (j=0; j<4; j++) { for (i=0; i<20; i++) { lambda = lambda - ldelta*one; if ( lambda <= min_l ) { lambda = min_l; i = 23; } if ( lambda >= max_l ) { lambda = max_l; i = 23; } N = N_of_l(lambda); cE = ewma_phat_crit(lambda, L0, 0., sigma, n, z0, LSL, USL, N, qm); L1_ = ewma_phat_arl(lambda, cE, mu, sigma, n, z0, LSL, USL, N, qm); if ( L1_ > L1 && i < 23 ) i = 21; L1 = L1_; } ldelta /= 10.; one *= -1.; } if ( i < 23 ) lambda -= 10.*ldelta*one; return lambda; } double ewma_phat_lambda2(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm, int M) { double dn, cS, cE, ldelta, one, L1, L1_, lambda; int i, j, N; lambda = 1.; dn = (double)n; cS = qPHI( 1. - 1./(2.*L0) )/sqrt(dn)*sigma; cE = WK_h( cS, 1., LSL, USL ); L1 = 1./( PHI( (-cS-mu)*sqrt(dn)/sigma, 0.) + 1. - PHI( (cS-mu)*sqrt(dn)/sigma, 0.) ); ldelta = .1; one = 1; for (j=0; j<4; j++) { for (i=0; i<20; i++) { lambda = lambda - ldelta*one; if ( lambda <= min_l ) { lambda = min_l; i = 23; } if ( lambda >= max_l ) { lambda = max_l; i = 23; } N = N_of_l(lambda); cE = ewma_phat_crit2(lambda, L0, 0., sigma, n, z0, LSL, USL, N, qm, M); L1_ = ewma_phat_arl2 (lambda, cE, mu, sigma, n, z0, LSL, USL, N, qm, M); if ( L1_ > L1 && i < 23 ) i = 21; L1 = L1_; } ldelta /= 10.; one *= -1.; } if ( i < 23 ) lambda -= 10.*ldelta*one; return lambda; } /* attributive EWMA */ double ewma_p_arl(double lambda, double ucl, int n, double p, double z0, int d_res, int round_mode, int mid_mode) { double *a, *g, arl, zj=0, pju, pj; int i, j, k, N, NN/*, k_max*/; N = (int)ceil(ucl*d_res); /*N = (int)floor(ucl*d_res);*/ NN = N + 1; a = matrix(NN, NN); g = vector(NN); for (i=0; i<=N; i++) for (j=0; j<=N; j++) a[i*NN+j] = 0.; for (i=0; i<=N; i++) { /*k_max = (int)ceil( (ucl+1. - (1.-lambda)*i)/lambda );*/ for (k=0; k<=n; k++) { zj = (1.-lambda)*i/d_res + lambda*k; pj = pdf_binom((double)k, n, p); switch (round_mode) { case -1: /* round down as probably Gan did */ j = (int)floor(zj*d_res + 1e-9); if ( j <= N ) a[i*NN+j] += -pj; break; case 0: /* round down */ j = (int)floor(zj*d_res); if ( j <= N ) a[i*NN+j] += -pj; break; case 1: /* round up */ j = (int)ceil(zj*d_res); if ( j <= N ) a[i*NN+j] += -pj; break; case 2: /* round to nearest -- round half to even, IEEE 754 */ j = (int)round(zj*d_res); if ( j <= N ) a[i*NN+j] += -pj; break; case 3: /* round to nearest -- round half up */ j = (int)floor(zj*d_res+.5); if ( j <= N ) a[i*NN+j] += -pj; break; case 4: /* distribute */ j = (int)floor(zj*d_res); pju = zj - j/d_res; if ( j <= N ) a[i*NN+j] += -(1.-pju)*pj; if ( j < N ) a[i*NN+j+1] += -pju*pj; break; } } ++a[i*NN+i]; } for (j=0; j<=N; j++) g[j] = 1.; LU_solve(a, g, NN); arl = 1.; /*k_max = (int)ceil( (ucl+1. - (1.-lambda)*z0)/lambda );*/ for (k=0; k<=n; k++) { zj = (1.-lambda)*z0 + lambda*k; pj = pdf_binom((double)k, n, p); switch (round_mode) { case -1: /* round down as probably Gan did */ j = (int)floor(zj*d_res + 1e-9); if ( j <= N ) arl += pj*g[j]; break; case 0: /* round down */ j = (int)floor(zj*d_res); if ( j <= N ) arl += pj*g[j]; break; case 1: /* round up */ j = (int)ceil(zj*d_res); if ( j <= N ) arl += pj*g[j]; break; case 2: /* round to nearest -- round half to even, IEEE 754 */ j = (int)round(zj*d_res); if ( j <= N ) arl += pj*g[j]; break; case 3: /* round to nearest -- round half up */ j = (int)floor(zj*d_res+.5); if ( j <= N ) arl += pj*g[j]; break; case 4: /* distribute */ j = (int)floor(zj*d_res); pju = zj - j/d_res; if ( j <= N ) arl += (1.-pju)*pj*g[j]; if ( j < N ) arl += pju*pj*g[j+1]; break; } } Free(a); Free(g); return arl; } /* 2-sided tolerance limits factors */ /* Wald & Wolfowitz */ double r_Fww (int n, double r) { double x1, x2; x1 = 1./sqrt(n*1.) - r; x2 = x1 + 2.*r; return ( PHI(x2,0.) - PHI(x1,0.) ); } double r_fww (int n, double r) { return( exp(-(1./n+r*r)/2.)*(exp(-r/sqrt(n*1.))+exp(r/sqrt(n*1.)))/sqrt(2.*PI) ); } double rww(int n, double p) { double r; r = .5; do r = r - (r_Fww(n,r)-p)/r_fww(n,r); while ( fabs(r_Fww(n,r)-p) > 1e-8 ); return r; } double kww(int n, double p, double a) { double k; k = rww(n,p); k *= sqrt( (n-1.) ); k /= sqrt( qCHI(a,n-1) ); return k; } /* exact by Gauss-Legendre quadrature */ double tl_rx_f(double x, double r) { return ( PHI(x+r,0.) - PHI(x-r,0.) ); } double tl_rx(double x, double p) { double r1, r2, r3, f1, f2, f3; r1 = 1.; f1 = tl_rx_f(x,r1); r2 = .8; f2 = tl_rx_f(x,r2); do { r3 = r1 - (f1-p)*(r2-r1)/(f2-f1); f3 = tl_rx_f(x,r3); if (f31e-8) && (fabs(r1-r2)>1e-8) ); return r3; } double tl_niveau(int n, double p, double k, int m) { double ni, xmax, *w, *z, dn, rxi; int i; ni = 0.; dn = (double) n; xmax = qPHI(1.-(1e-10)/2.)/sqrt(dn); w = vector(m); z = vector(m); gausslegendre(m,0.,xmax,z,w); for (i=0;i 1e-8 ) && ( fabs(dk) > 1e-7 ) ); return k2; } /* solution of Ax = b with nxn matrix A and and n-dim vectors x and b */ /* by means of LU decomposition etc. */ int LU_decompose(double *a, int *ps, int n) { int i, j, k; int pii = 0; double pivot, biggest, mult, t, *lu, *scales; lu = matrix(n,n); scales = vector(n); for (i=0;i=0;i--) { dot = 0.; for (j=i+1;j=0;i--) { dot = 0.; for (j=i+1;j #include #include #include #define cusum1 0 #define cusum2 1 double xtc1_iglarl(double k, double h, double hs, int df, double mu, int N, int subst); double xtc2_iglarl(double k, double h, double hs, int df, double mu, int N, int subst); void xtcusum_arl ( int *ctyp, double *k, double *h, double *hs, int *df, double *mu, int *r, int *ntyp, double *arl) { if ( *ctyp == cusum1 ) *arl = xtc1_iglarl(*k, *h, *hs, *df, *mu, *r, *ntyp); if ( *ctyp == cusum2 ) *arl = xtc2_iglarl(*k, *h, *hs, *df, *mu, *r, *ntyp); } spc/src/ewma_phat_arl_coll.c0000644000175100001440000000235112655133155015633 0ustar hornikusers#include #include #include #include double ewma_phat_arl(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm); double ewma_phat_arl_be(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N); double ewma_phat_arl2(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M); double ewma_phat_arl2_be(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N); void ewma_phat_arl_coll (double *lambda, double *ucl, double *mu, double *sigma, int *n, double *z0, int *ctyp, double *LSL, double *USL, int *N, int *qm, int *ntyp, double *arl) { int M=4; *arl = -1.; if ( *ctyp == 0 ) { if ( *ntyp == 0 ) *arl = ewma_phat_arl(*lambda, *ucl, *mu, *sigma, *n, *z0, *LSL, *USL, *N, *qm); if ( *ntyp == 1 ) *arl = ewma_phat_arl_be(*lambda, *ucl, *mu, *sigma, *n, *z0, *LSL, *USL, *N); } if ( *ctyp == 1 ) { if ( *ntyp == 0 ) *arl = ewma_phat_arl2(*lambda, *ucl, *mu, *sigma, *n, *z0, *LSL, *USL, *N, *qm, M); if ( *ntyp == 1 ) *arl = ewma_phat_arl2_be(*lambda, *ucl, *mu, *sigma, *n, *z0, *LSL, *USL, *N); } } spc/src/xsewma_q_crit.c0000644000175100001440000000336612655133155014673 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewma2 1 #define fixed 0 #define unbiased 1 int xseU_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error); int xse2fu_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error); int xse2_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error); void xsewma_q_crit ( int *ctyp, int *ltyp, double *lx, double *ls, double *L0, double *alpha, double *cu0, double *hsx, double *hss, double *mu, double *sigma, int *df, int *Nx, int *Ns, int *qm, double *c_error, double *a_error, double *c_values) { int result=0; double cx=-1., cl=0., cu=-1.; if ( *ctyp==ewmaU ) result = xseU_q_crit(*lx, *ls, *L0, *alpha, &cx, &cu, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, *qm, *c_error, *a_error); if ( *ctyp==ewma2 ) { if ( *ltyp==fixed ) { result = xse2fu_q_crit(*lx, *ls, *L0, *alpha, &cx, &cl, *cu0, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, *qm, *c_error, *a_error); cu = *cu0; } if ( *ltyp==unbiased ) result = xse2_q_crit(*lx, *ls, *L0, *alpha, &cx, &cl, &cu, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, *qm, *c_error, *a_error); } if ( result != 0 ) warning("trouble with xsewma_q_crit [package spc]"); c_values[0] = cx; c_values[1] = cl; c_values[2] = cu; } spc/src/xsewma_res_arl.c0000644000175100001440000000107512655133155015034 0ustar hornikusers#include #include #include #include double xseU_arl_RES (double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double alpha); void xsewma_res_arl ( double *alpha, int *n, int *ctyp, double *lx, double *cx, double *hsx, int *Nx, double *ls, double *csu, double *hss, int *Ns, double *mu, double *sigma, int *qm, double *arl) { *arl = -1.; *arl = xseU_arl_RES(*lx,*ls,*cx,*csu,*hsx,*hss,*mu,*sigma,*n,*Nx,*Ns,10000,*qm,*alpha); } spc/src/xcusum_crit.c0000644000175100001440000000047012655133155014364 0ustar hornikusers#include #include #include #include extern double rho0; double xc_crit(int ctyp, double k, double L0, double hs, double m0, int N); void xcusum_crit(int *ctyp, double *k, double *L0, double *hs, double *mu0, int *r, double *h) { *h = xc_crit(*ctyp,*k,*L0,*hs,*mu0,*r); } spc/src/xewma_arl.c0000644000175100001440000000546612655133155014010 0ustar hornikusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define stat 5 #define fink 6 #define elimit 7 #define waldmann 8 #define collocation 9 extern double rho0; double *vector (long n); double xe1_iglarl(double l, double c, double zr, double hs, double mu, int N); double xe1_arlm(double l, double c, double zr, double hs, int q, double mu0, double mu1,int mode, int N, int nmax); double xe1_arlm_hom(double l, double c, double zr, double hs, int q, double mu0, double mu1, int N, double *ced); double xlimit1_arlm(double c, double zr, int q, double mu0, double mu1, int N, int nmax); double xe1_Warl(double l, double c, double zr, double hs, double mu, int N, int nmax); double xe2_iglarl(double l, double c, double hs, double mu, int N); double xe2_Warl(double l, double c, double hs, double mu, int N, int nmax); double xe2_Carl(double l, double c, double hs, double mu, int N, int qm); double xe2_arlm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); double xe2_arlm_hom(double l, double c, double hs, int q, double mu0, double mu1, int N, double *ced); void xewma_arl(int *ctyp, double *l, double *c, double *zr, double *hs, double *mu, int *ltyp, int *r, int *q, double *arl) { int nmax=100000, i, result=0; double *ced, arl1=-1.; ced = vector(*q); if (*ctyp==ewma1 && *ltyp==fix && *q==1) arl1 = xe1_iglarl(*l,*c,*zr,*hs,*mu,*r); if (*ctyp==ewma1 && *ltyp==fix && *q>1) result = xe1_arlm_hom(*l, *c, *zr, *hs, *q, 0., *mu, *r, ced); /* *arl = xe1_arlm(*l,*c,*zr,*hs,*q,0.,*mu,*ltyp,*r,nmax);*/ if (*ctyp==ewma1 && *ltyp>fix && *ltyp1) result = xe2_arlm_hom(*l, *c, *hs, *q, 0., *mu, *r, ced); /* arl1 = xe2_arlm(*l,*c,*hs,*q,0.,*mu,*ltyp,*r,nmax);*/ if (*ctyp==ewma2 && *ltyp>fix && *ltyp1 ) for (i=0; i<*q; i++) arl[i] = ced[i]; else *arl = arl1; } spc/src/xewma_q.c0000644000175100001440000000261112655133155013457 0ustar hornikusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define stat 5 #define test 6 double xe1_Wq(double l, double c, double p, double zr, double hs, double mu, int N, int nmax); double xe1_Wqm(double l, double c, double p, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); double xe2_Wq(double l, double c, double p, double hs, double mu, int N, int nmax); double xe2_Wqm(double l, double c, double p, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); void xewma_q(int *ctyp, double *l, double *c, double *p, double *zr, double *hs, double *mu, int *ltyp, int *r, int *q, double *tq) { int nmax=1000000; if ( *ctyp==ewma1 && *ltyp==fix && *q==1 ) *tq = xe1_Wq(*l, *c, *p, *zr, *hs, *mu, *r, nmax); if ( *ctyp==ewma1 && *ltyp==fix && *q>1 ) *tq = xe1_Wqm(*l, *c, *p, *zr, *hs, *q, 0., *mu, *ltyp, *r, nmax); if ( *ctyp==ewma1 && *ltyp>fix ) *tq = xe1_Wqm(*l, *c, *p, *zr, *hs, *q, 0., *mu, *ltyp, *r, nmax); if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xe2_Wq(*l, *c, *p, *hs, *mu, *r, nmax); if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xe2_Wqm(*l, *c, *p, *hs, *q, 0., *mu, *ltyp, *r, nmax); if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xe2_Wqm(*l, *c, *p, *hs, *q, 0., *mu, *ltyp, *r, nmax); } spc/src/xtewma_sf.c0000644000175100001440000000230412655133155014012 0ustar hornikusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 double *vector (long n); /* double xe1_sf (double l, double c, double zr, double hs, double mu, int N, int nmax, double *p0); double xe1_sfm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0); */ double xte2_sf(double l, double c, double hs, int df, double mu, int N, int nmax, double *p0, int subst); double xte2_sfm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0, int subst); void xtewma_sf(int *ctyp, double *l, double *c, double *zr, double *hs, int *df, double *mu, int *ltyp, int *r, int *ntyp, int *q, int *n, double *sf) { int result=0, i; double *p0; p0 = vector(*n); if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) { result = xte2_sf(*l, *c, *hs, *df, *mu, *r, *n, p0, *ntyp); } if ( *ctyp==ewma2 && ( ( *ltyp==fix && *q>1 ) || ( *ltyp>fix) ) ) { result = xte2_sfm(*l, *c, *hs, *df, *q, 0., *mu, *ltyp, *r, *n, p0, *ntyp); } if ( result != 0 ) warning("trouble in xtewma_sf [package spc]"); for (i=0; i<*n; i++) sf[i] = p0[i]; } spc/src/xDcusum_arl.c0000644000175100001440000000165412655133155014312 0ustar hornikusers#include #include #include #include #define cusum1 0 #define cusum2 1 #define cusumC 2 #define Gan 0 #define Knoth 1 extern double rho0; double xc1_iglarl_drift(double k, double h, double hs, double delta, int m, int N, int with0); double xc1_iglarl_drift_wo_m(double k, double h, double hs, double delta, int *m, int N, int with0); double xc1_iglarlm_drift(double k, double h, double hs, int q, double delta, int N, int nmax, int with0); void xDcusum_arl ( int *ctyp, double *k, double *h, double *hs, double *delta, int *m, int *r, int *with0, int *mode, int *q, double *arl) { if (*ctyp==cusum1 && *m>0) *arl = xc1_iglarl_drift(*k, *h, *hs, *delta, *m, *r, *with0); if (*ctyp==cusum1 && *m==0 && *mode==Gan) *arl = xc1_iglarl_drift_wo_m(*k, *h, *hs, *delta, m, *r, *with0); if (*ctyp==cusum1 && *m==0 && *mode==Knoth) *arl = xc1_iglarlm_drift(*k, *h, *hs, *q, *delta, *r, 10000, *with0); } spc/src/xewma_q_prerun.c0000644000175100001440000000557412655133155015065 0ustar hornikusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define stat 5 #define MU 0 #define SIGMA 1 #define BOTH 2 double xe2_Wq_prerun_MU_deluxe(double l, double c, double p, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND); double xe2_Wq_prerun_SIGMA_deluxe(double l, double c, double p, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND); double xe2_Wq_prerun_BOTH_deluxe(double l, double c, double p, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double BOUND); double xe2_Wqm_prerun_MU_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND); double xe2_Wqm_prerun_SIGMA_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND); double xe2_Wqm_prerun_BOTH_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double BOUND); void xewma_q_prerun ( int *ctyp, double *l, double *c, double *p, double *zr, double *hs, double *mu, int *ltyp, int *q, int *size, int *df, int *mode, int *qm1, int *qm2, double *truncate, double *bound, double *tq) { int nmax=1000000; if ( *mode == MU ) { if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xe2_Wq_prerun_MU_deluxe(*l, *c, *p, *hs, *mu, *size, nmax, *qm1, *truncate, *bound); if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xe2_Wqm_prerun_MU_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm1, *truncate, *bound); if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xe2_Wqm_prerun_MU_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm1, *truncate, *bound); } if ( *mode == SIGMA ) { if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xe2_Wq_prerun_SIGMA_deluxe(*l, *c, *p, *hs, *mu, *size, nmax, *qm2, *truncate, *bound); if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xe2_Wqm_prerun_SIGMA_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm2, *truncate, *bound); if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xe2_Wqm_prerun_SIGMA_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm2, *truncate, *bound); } if ( *mode == BOTH ) { if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xe2_Wq_prerun_BOTH_deluxe(*l, *c, *p, *hs, *mu, *size, *df, nmax, *qm1, *qm2, *truncate, *bound); if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xe2_Wqm_prerun_BOTH_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *df, *ltyp, nmax, *qm1, *qm2, *truncate, *bound); if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xe2_Wqm_prerun_BOTH_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *df, *ltyp, nmax, *qm1, *qm2, *truncate, *bound); } } spc/src/sewma_crit.c0000644000175100001440000000661712655133155014165 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 #define fixed 0 #define unbiased 1 #define eqtails 2 #define sym 3 double seU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm); double seUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm); double seLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); double se2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); int se2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm); int se2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm); double se2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm); double stdeU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm); double stdeUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm); double stdeLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); double stde2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); int stde2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm); int stde2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm); double stde2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm); double c_four(double ddf); void sewma_crit ( int *ctyp, int *ltyp, double *l, double *L0, double *cl0, double *cu0, double *hs, double *sigma, int *df, int *r, int *qm, double *ur, int *s_squared, double *c_values) { int result=0; double cl=0., cu=1., mitte=1.; if ( *s_squared==1 ) { if (*ctyp==ewmaU) cu = seU_crit(*l,*L0,*hs,*sigma,*df,*r,*qm); if (*ctyp==ewmaUR) cu = seUR_crit(*l,*L0,*cl0,*hs,*sigma,*df,*r,*qm); if (*ctyp==ewmaLR) cl = seLR_crit(*l,*L0,*cu0,*hs,*sigma,*df,*r,*qm); if (*ctyp==ewma2) { if (*ltyp==fixed) { cl = se2fu_crit(*l,*L0,*cu0,*hs,*sigma,*df,*r,*qm); cu = *cu0; } if (*ltyp==unbiased) result = se2_crit_unbiased(*l, *L0, &cl, &cu, *hs, *sigma, *df, *r, *qm); if (*ltyp==eqtails) result = se2_crit_eqtails(*l, *L0, &cl, &cu, *hs, *sigma, *df, *ur, *r, *qm); if (*ltyp==sym) { cu = se2_crit_sym(*l, *L0, *hs, *sigma, *df, *r, *qm); cl = 2. - cu; } } } else { mitte = c_four((double)*df); if ( *ctyp==ewmaU ) cu = stdeU_crit(*l,*L0,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewmaUR ) cu = stdeUR_crit(*l,*L0,*cl0,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewmaLR ) cl = stdeLR_crit(*l,*L0,*cu0,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewma2 ) { if ( *ltyp==fixed ) { cl = stde2fu_crit(*l,*L0,*cu0,*hs,*sigma,*df,*r,*qm); cu = *cu0; } if ( *ltyp==unbiased ) result = stde2_crit_unbiased(*l, *L0, &cl, &cu, *hs, *sigma, *df, *r, *qm); if ( *ltyp==eqtails ) result = stde2_crit_eqtails(*l, *L0, &cl, &cu, *hs, *sigma, *df, *ur, *r, *qm); if ( *ltyp==sym ) { cu = stde2_crit_sym(*l, *L0, *hs, *sigma, *df, *r, *qm); cl = 2.*mitte - cu; } } } if ( result != 0 ) warning("trouble with se2_crit called from sewma_crit [package spc]"); c_values[0] = cl; c_values[1] = cu; } spc/src/xsewma_res_pms.c0000644000175100001440000000120212655133155015045 0ustar hornikusers#include #include #include #include double xseU_mu_before_sigma_RES (double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double alpha, int vice_versa); void xsewma_res_pms ( double *alpha, int *n, int *ctyp, double *lx, double *cx, double *hsx, int *Nx, double *ls, double *csu, double *hss, int *Ns, double *mu, double *sigma, int *qm, int *vice_versa, double *pms) { *pms = -1.; *pms = xseU_mu_before_sigma_RES(*lx,*ls,*cx,*csu,*hsx,*hss,*mu,*sigma,*n,*Nx,*Ns,10000,*qm,*alpha,*vice_versa); } spc/src/phat_cdf.c0000644000175100001440000000103412655133155013564 0ustar hornikusers#include #include #include #include double cdf_phat(double p, double mu, double sigma, int n, double LSL, double USL); double cdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes); void phat_cdf (double *x, int *n, double *mu, double *sigma, int *ctyp, double *LSL, double *USL, int *nodes, double *cdf) { *cdf = -1.; if ( *ctyp == 0 ) *cdf = cdf_phat(*x, *mu, *sigma, *n, *LSL, *USL); if ( *ctyp == 1 ) *cdf = cdf_phat2(*x, *mu, *sigma, *n, *LSL, *USL, *nodes); } spc/src/sewma_arl_prerun.c0000644000175100001440000000260012655133155015361 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 double seU_iglarl_prerun_SIGMA(double l, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seUR_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double se2_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seLR_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); void sewma_arl_prerun ( int *ctyp, double *l, double *cl, double *cu, double *hs, double *sigma, int *df1, int *N, int *qm1, int *df2, int *qm2, double *truncate, double *arl) { *arl = -1.; if ( *ctyp==ewmaU ) *arl = seU_iglarl_prerun_SIGMA(*l, *cu, *hs, *sigma, *df1, *df2, *N, *qm1, *qm2, *truncate); if ( *ctyp==ewma2 ) *arl = se2_iglarl_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *N, *qm1, *qm2, *truncate); if ( *ctyp==ewmaUR ) *arl = seUR_iglarl_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *N, *qm1, *qm2, *truncate); if ( *ctyp==ewmaLR ) *arl = seLR_iglarl_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *N, *qm1, *qm2, *truncate); } spc/src/ewma_phat_lambda_coll.c0000644000175100001440000000142312655133155016274 0ustar hornikusers#include #include #include #include double ewma_phat_lambda(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm); double ewma_phat_lambda2(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm, int M); void ewma_phat_lambda_coll (double *L0, double *mu, double *sigma, int *ctyp, double *max_l, double *min_l, int *n, double *z0, double *LSL, double *USL, int *qm, double *lambda) { int M=4; *lambda = -1.; if ( *ctyp == 0 ) *lambda = ewma_phat_lambda(*L0, *mu, *sigma, *max_l, *min_l, *n, *z0, *LSL, *USL, *qm); if ( *ctyp == 1 ) *lambda = ewma_phat_lambda2(*L0, *mu, *sigma, *max_l, *min_l, *n, *z0, *LSL, *USL, *qm, M); } spc/src/sewma_q.c0000644000175100001440000000212012655133155013445 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 double seU_Wq(double l, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); double se2_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); double seUR_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); double seLR_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); void sewma_q(int *ctyp, double *l, double *cl, double *cu, double *p, double *hs, int *N, double *sigma, int *df, int *qm, double *tq) { int nmax=100000; if ( *ctyp == ewmaU ) *tq = seU_Wq(*l, *cu, *p, *hs, *sigma, *df, *N, nmax, *qm); if ( *ctyp == ewma2 ) *tq = se2_Wq(*l, *cl, *cu, *p, *hs, *sigma, *df, *N, nmax, *qm); if ( *ctyp == ewmaUR ) *tq = seUR_Wq(*l, *cl, *cu, *p, *hs, *sigma, *df, *N, nmax, *qm); if ( *ctyp == ewmaLR ) *tq = seLR_Wq(*l, *cl, *cu, *p, *hs, *sigma, *df, *N, nmax, *qm); } spc/src/xsewma_sf.c0000644000175100001440000000213412655133155014012 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 double *vector (long n); double xseU_sf(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0); double xse2_sf(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0); void xsewma_sf ( int *ctyp, double *lx, double *cx, double *hsx, int *Nx, double *ls, double *csl, double *csu, double *hss, int *Ns, double *mu, double *sigma, int *df, int *qm, int *n, double *sf) { int result=0, i; double *p0; p0 = vector(*n); if ( *ctyp == ewmaU ) result = xseU_sf(*lx, *ls, *cx, *csu, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, *n, *qm, p0); if ( *ctyp == ewma2 ) result = xse2_sf(*lx, *ls, *cx, *csl, *csu, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, *n, *qm, p0); if ( result != 0 ) warning("trouble in xsewma_sf [package spc]"); for (i=0; i<*n; i++) sf[i] = p0[i]; } spc/src/xDewma_arl.c0000644000175100001440000000362312655133155014105 0ustar hornikusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define sven 5 #define fink 6 #define waldmann 7 #define collocation 8 #define Gan 0 #define Knoth 1 #define Waldm 2 extern double rho0; double xe1_iglarl_drift(double l, double c, double zr, double hs, double delta, int m, int N, int with0); double xe1_iglarl_drift_wo_m(double l, double c, double zr, double hs, double delta, int *m, int N, int with0); double xe1_iglarlm_drift(double l, double c, double zr, double hs, int q, double delta, int N, int nmax, int with0); double xe2_iglarl_drift(double l, double c, double hs, double delta, int m, int N, int with0); double xe2_iglarl_drift_wo_m(double l, double c, double hs, double delta, int *m, int N, int with0); double xe2_iglarlm_drift(double l, double c, double hs, int q, double delta, int N, int nmax, int with0); double xe2_Warl_drift(double l, double c, double hs, double delta, int N, int nmax, int with0); void xDewma_arl ( int *ctyp, double *l, double *c, double *zr, double *hs, double *delta, int *ltyp, int *m, int *r, int *with0, int *mode, int *q, double *arl) { if (*ctyp==ewma1 && *m>0) *arl = xe1_iglarl_drift(*l,*c,*zr,*hs,*delta,*m,*r,*with0); if (*ctyp==ewma1 && *m==0 && *mode==Gan) *arl = xe1_iglarl_drift_wo_m(*l,*c,*zr,*hs,*delta,m,*r,*with0); if (*ctyp==ewma1 && *m==0 && *mode==Knoth) *arl = xe1_iglarlm_drift(*l,*c,*zr,*hs,*q,*delta,*r,10000,*with0); if (*ctyp==ewma2 && *m>0) *arl = xe2_iglarl_drift(*l,*c,*hs,*delta,*m,*r,*with0); if (*ctyp==ewma2 && *m==0 && *mode==Gan) *arl = xe2_iglarl_drift_wo_m(*l,*c,*hs,*delta,m,*r,*with0); if (*ctyp==ewma2 && *m==0 && *mode==Knoth) *arl = xe2_iglarlm_drift(*l,*c,*hs,*q,*delta,*r,10000,*with0); if (*ctyp==ewma2 && *m==0 && *mode==Waldm) *arl = xe2_Warl_drift(*l,*c,*hs,*delta,*r,10000,*with0); } spc/src/mewma_arl.c0000644000175100001440000000713512655133155013770 0ustar hornikusers#include #include #include #include #define GL 0 #define CO 1 #define RA 2 #define CC 3 #define MC 4 #define SR 5 #define CO2 6 #define GL2 7 #define GL3 8 #define GL4 9 #define GL5 10 #define CO3 11 #define CO4 12 double mxewma_arl_0a(double lambda, double ce, int p, double hs, int N); double mxewma_arl_0a2(double lambda, double ce, int p, double hs, int N); double mxewma_arl_0b(double lambda, double ce, int p, double hs, int N, int qm); double mxewma_arl_0c(double lambda, double ce, int p, double hs, int N); double mxewma_arl_0d(double lambda, double ce, int p, double hs, int N); double mxewma_arl_0e(double lambda, double ce, int p, double hs, int N); double mxewma_arl_0f(double lambda, double ce, int p, double hs, int N); double mxewma_arl_1a(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1a2(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1a3(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1a4(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1a5(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1b(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); double mxewma_arl_1b2(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); double mxewma_arl_1b3(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); double mxewma_arl_1b4(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); double mxewma_arl_1c(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1d(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1e(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1f(double lambda, double ce, int p, double delta, double hs, int N); void mewma_arl(double *l, double *c, int *p, double *delta, double *hs, int *r, int *qtype, int *qm0, int *qm1, double *arl) { if ( fabs(*delta)<1e-10 ) { if ( *qtype == GL ) *arl = mxewma_arl_0a(*l, *c, *p, *hs, *r); if ( *qtype == GL2 ) *arl = mxewma_arl_0a2(*l, *c, *p, *hs, *r); if ( *qtype == CO ) *arl = mxewma_arl_0b(*l, *c, *p, *hs, *r, *qm0); if ( *qtype == RA ) *arl = mxewma_arl_0c(*l, *c, *p, *hs, *r); if ( *qtype == CC ) *arl = mxewma_arl_0d(*l, *c, *p, *hs, *r); if ( *qtype == MC ) *arl = mxewma_arl_0e(*l, *c, *p, *hs, *r); if ( *qtype == SR ) *arl = mxewma_arl_0f(*l, *c, *p, *hs, *r); } else { if ( *qtype == GL ) *arl = mxewma_arl_1a(*l, *c, *p, *delta, *hs, *r); if ( *qtype == GL2 ) *arl = mxewma_arl_1a2(*l, *c, *p, *delta, *hs, *r); if ( *qtype == GL3 ) *arl = mxewma_arl_1a3(*l, *c, *p, *delta, *hs, *r); if ( *qtype == GL4 ) *arl = mxewma_arl_1a4(*l, *c, *p, *delta, *hs, *r); if ( *qtype == GL5 ) *arl = mxewma_arl_1a5(*l, *c, *p, *delta, *hs, *r); if ( *qtype == CO ) *arl = mxewma_arl_1b(*l, *c, *p, *delta, *hs, *r, *qm0, *qm1); if ( *qtype == CO2 ) *arl = mxewma_arl_1b2(*l, *c, *p, *delta, *hs, *r, *qm0, *qm1); if ( *qtype == CO3 ) *arl = mxewma_arl_1b3(*l, *c, *p, *delta, *hs, *r, *qm0, *qm1); if ( *qtype == CO4 ) *arl = mxewma_arl_1b4(*l, *c, *p, *delta, *hs, *r, *qm0, *qm1); if ( *qtype == RA ) *arl = mxewma_arl_1c(*l, *c, *p, *delta, *hs, *r); if ( *qtype == CC ) *arl = mxewma_arl_1d(*l, *c, *p, *delta, *hs, *r); if ( *qtype == MC ) *arl = mxewma_arl_1e(*l, *c, *p, *delta, *hs, *r); if ( *qtype == SR ) *arl = mxewma_arl_1f(*l, *c, *p, *delta, *hs, *r); } } spc/src/xsewma_q.c0000644000175100001440000000166712655133155013654 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewma2 1 double xseU_Wq(double lx, double ls, double cx, double cs, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); double xse2_Wq(double lx, double ls, double cx, double csl, double csu, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); void xsewma_q ( int *ctyp, double *alpha, double *lx, double *cx, double *hsx, int *Nx, double *ls, double *csl, double *csu, double *hss, int *Ns, double *mu, double *sigma, int *df, int *qm, double *tq) { int nmax=100000; *tq = -1.; if ( *ctyp == ewmaU ) *tq = xseU_Wq(*lx, *ls, *cx, *csu, *alpha, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, nmax, *qm); if ( *ctyp == ewma2 ) *tq = xse2_Wq(*lx, *ls, *cx, *csl, *csu, *alpha, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, nmax, *qm); } spc/src/xewma_ad.c0000644000175100001440000000251612655133155013607 0ustar hornikusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define stat 5 #define fink 6 #define conditional 0 #define cyclical 1 extern double rho0; double xe1_iglad(double l, double c, double zr, double mu0, double mu1, int N); double xe1_arlm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); double xe2_iglad (double l, double c, double mu0, double mu1, int N); double xe2_igladc(double l, double c, double mu0, double mu1, double z0, int N); double xe2_arlm (double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); void xewma_ad(int *ctyp, double *l, double *c, double *zr, double *mu0, double *mu1, double *z0, int *ltyp, int *styp, int *r, double *ad) { int nmax=1000000; if ( *styp==conditional ) { if ( *ctyp==ewma1 && *ltyp==fix ) *ad = xe1_iglad(*l,*c,*zr,*mu0,*mu1,*r); if ( *ctyp==ewma1 && *ltyp>fix ) *ad = xe1_arlm(*l,*c,*zr,0.,200,*mu0,*mu1,*ltyp,*r,nmax); if ( *ctyp==ewma2 && *ltyp==fix ) *ad = xe2_iglad(*l,*c,*mu0,*mu1,*r); if ( *ctyp==ewma2 && *ltyp>fix ) *ad = xe2_arlm(*l,*c,0.,200,*mu0,*mu1,*ltyp,*r,nmax); } else { if ( *ctyp==ewma2 && *ltyp==fix ) *ad = xe2_igladc(*l, *c, *mu0, *mu1, *z0, *r); } } spc/src/phat_pdf.c0000644000175100001440000000103612655133155013603 0ustar hornikusers#include #include #include #include double pdf_phat (double p, double mu, double sigma, int n, double LSL, double USL); double pdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes); void phat_pdf (double *x, int *n, double *mu, double *sigma, int *ctyp, double *LSL, double *USL, int *nodes, double *pdf) { *pdf = -1.; if ( *ctyp == 0 ) *pdf = pdf_phat (*x, *mu, *sigma, *n, *LSL, *USL); if ( *ctyp == 1 ) *pdf = pdf_phat2(*x, *mu, *sigma, *n, *LSL, *USL, *nodes); } spc/src/xsewma_crit.c0000644000175100001440000000326212655133155014346 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 #define fixed 0 #define unbiased 1 int xseU_crit (double lx, double ls, double L0, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); int xse2lu_crit (double lx, double ls, double L0, double *cx, double csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); int xse2fu_crit (double lx, double ls, double L0, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); int xse2_crit (double lx, double ls, double L0, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); void xsewma_crit ( int *ctyp, int *ltyp, double *lx, double *ls, double *L0, double *cu0, double *hsx, double *hss, double *mu, double *sigma, int *df, int *Nx, int *Ns, int *qm, double *c_values) { int result=0; double cx, cl, cu; cx = -1.; cl = 0.; cu = -1.; if (*ctyp==ewmaU) result = xseU_crit(*lx,*ls,*L0,&cx,&cu,*hsx,*hss,*mu,*sigma,*df,*Nx,*Ns,10000,*qm); if (*ctyp==ewma2) { if (*ltyp==fixed) { result = xse2fu_crit(*lx,*ls,*L0,&cx,&cl,*cu0,*hsx,*hss,*mu,*sigma,*df,*Nx,*Ns,10000,*qm); cu = *cu0; } if (*ltyp==unbiased) result = xse2_crit(*lx,*ls,*L0,&cx,&cl,&cu,*hsx,*hss,*mu,*sigma,*df,*Nx,*Ns,10000,*qm); } if ( result != 0 ) warning("trouble with xsewma_crit [package spc]"); c_values[0] = cx; c_values[1] = cl; c_values[2] = cu; } spc/src/phat_qf.c0000644000175100001440000000102512655133155013436 0ustar hornikusers#include #include #include #include double qf_phat(double p0, double mu, double sigma, int n, double LSL, double USL); double qf_phat2(double p0, double mu, double sigma, int n, double LSL, double USL, int nodes); void phat_qf (double *x, int *n, double *mu, double *sigma, int *ctyp, double *LSL, double *USL, int *nodes, double *qf) { *qf = -1.; if ( *ctyp == 0 ) *qf = qf_phat(*x, *mu, *sigma, *n, *LSL, *USL); if ( *ctyp == 1 ) *qf = qf_phat2(*x, *mu, *sigma, *n, *LSL, *USL, *nodes); } spc/src/mewma_crit.c0000644000175100001440000000041512655133155014145 0ustar hornikusers#include #include #include #include double mxewma_crit(double lambda, double L0, int p, double hs, int N); void mewma_crit(double *l, double *L0, int *p, double *hs, int *r, double *h) { *h = mxewma_crit(*l, *L0, *p, *hs, *r); } spc/src/scusum_arl.c0000644000175100001440000000245212655133155014176 0ustar hornikusers#include #include #include #include #define cusumU 0 #define cusumL 1 #define cusum2 2 double scU_iglarl_v1(double refk, double h, double hs, double sigma, int df, int N, int qm); double scU_iglarl_v2(double refk, double h, double hs, double sigma, int df, int N, int qm); double scL_iglarl_v2(double refk, double h, double hs, double sigma, int df, int N, int qm); double sc2_iglarl_v2(double refkl, double refku, double hl, double hu, double hsl, double hsu, double sigma, int df, int N, int qm); void scusum_arl ( int *ctyp, double *k, double *h, double *hs, double *sigma, int *df, double *k2, double *h2, double *hs2, int *r, int *qm, int *version, double *arl) { *arl = -1.; if ( *ctyp==cusumU ) { if ( *version==1 ) *arl = scU_iglarl_v1(*k, *h, *hs, *sigma, *df, *r, *qm); if ( *version==2 ) *arl = scU_iglarl_v2(*k, *h, *hs, *sigma, *df, *r, *qm); } if ( *ctyp==cusumL ) { /*if ( *version==1 ) *arl = scL_iglarl_v1(*k, *h, *hs, *sigma, *df, *r, *qm);*/ if ( *version==2 ) *arl = scL_iglarl_v2(*k, *h, *hs, *sigma, *df, *r, *qm); } if ( *ctyp==cusum2 ) { /*if ( *version==1 ) *arl = sc2_iglarl_v1(*k2, *k, *h2, *h, *hs2, *hs, *sigma, *df, *r, *qm);*/ if ( *version==2 ) *arl = sc2_iglarl_v2(*k2, *k, *h2, *h, *hs2, *hs, *sigma, *df, *r, *qm); } } spc/src/lns2ewma_arl.c0000644000175100001440000000131012655133155014377 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewmaL 1 #define ewma2 2 double lns2ewmaU_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N); double lns2ewma2_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N); void lns2ewma_arl ( int *ctyp, double *l, double *cl, double *cu, double *hs, double *sigma, int *df, int *r, double *arl) { *arl = -1.; if ( *ctyp==ewmaU ) *arl = lns2ewmaU_arl_igl(*l, *cl, *cu, *hs, *sigma, *df, *r); /*if ( *ctyp==ewmaL ) *arl = lns2ewmaL_arl_igl(*l, *cl, *cu, *hs, *sigma, *df, *r);*/ if ( *ctyp==ewma2 ) *arl = lns2ewma2_arl_igl(*l, *cl, *cu, *hs, *sigma, *df, *r); } spc/src/xgrsr_arl.c0000644000175100001440000000210212655133155014014 0ustar hornikusers#include #include #include #include #define grsr1 0 #define grsr2 1 extern double rho0; double *vector (long n); double xsr1_iglarl(double k, double h, double zr, double hs, double mu, int N, int MPT); double xsr1_arlm(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int nmax, int MPT); double xsr1_arlm_hom(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int MPT, double *ced); void xgrsr_arl(int *ctyp, double *k, double *h, double *zr, double *hs, double *mu, int *q, int *r, int *MPT, double *arl) { int i, /*nmax=100000,*/ result=0; double *ced, arl1=-1.; ced = vector(*q); if ( *ctyp==grsr1 && *q==1 ) arl1 = xsr1_iglarl(*k, *h, *zr, *hs, *mu, *r, *MPT); if ( *ctyp==grsr1 && *q>1 ) result = xsr1_arlm_hom(*k, *h, *zr, *hs, *q, 0., *mu, *r, *MPT, ced); /* *arl = xsr1_arlm(*k, *h, *zr, *hs, *q, 0., *mu, *r, nmax, *MPT);*/ if ( result != 0 ) warning("trouble in xgrsr_arl [package spc]"); if ( *q > 1 ) for (i=0; i<*q; i++) arl[i] = ced[i]; else *arl = arl1; } spc/src/scusum_crit.c0000644000175100001440000000202612655133155014356 0ustar hornikusers#include #include #include #include #define cusumU 0 #define cusumL 1 #define cusum2 2 double scU_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm); double scL_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm); int sc2_crit_unbiased(double refkl, double refku, double L0, double *hl, double *hu, double hsl, double hsu, double sigma, int df, int N, int qm); void scusum_crit(int *ctyp, double *k, double *L0, double *hs, double *sigma, int *df, int *ltyp, double *k2, double *hs2, int *r, int *qm, double *h) { int result=0; double hl=0., hu=0.; if ( *ctyp==cusumU ) *h = scU_crit(*k, *L0, *hs, *sigma, *df, *r, *qm); if ( *ctyp==cusumL ) *h = scL_crit(*k, *L0, *hs, *sigma, *df, *r, *qm); if ( *ctyp==cusum2 ) { result = sc2_crit_unbiased(*k2, *k, *L0, &hl, &hu, *hs2, *hs, *sigma, *df, *r, *qm); if ( result != 0 ) warning("trouble with sc2_crit_unbiased called from scusum_crit [package spc]"); h[0] = hl; h[1] = hu; } } spc/src/lns2ewma_crit.c0000644000175100001440000000315712655133155014575 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewmaL 1 #define ewma2 2 #define fixed 0 #define unbiased 1 #define eqtails 2 #define sym 3 double lns2ewmaU_crit(double l, double L0, double cl, double hs, double sigma, int df, int N); double lns2ewma2_crit_cufix(double l, double cu, double L0, double hs, double sigma, int df, int N); double lns2ewma2_crit_sym(double l, double L0, double hs, double sigma, int df, int N); int lns2ewma2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N); void lns2ewma_crit ( int *ctyp, int *ltyp, double *l, double *L0, double *cl0, double *cu0, double *hs, double *sigma, int *df, int *r, double *c_values) { int result=0; double cl=0., cu=1., ddf=1., mitte=0.; ddf = (double)*df; mitte = -1./ddf - 1./3./ddf/ddf + 2./15./ddf/ddf/ddf/ddf; if ( *ctyp==ewmaU ) cu = lns2ewmaU_crit(*l, *L0, *cl0, *hs, *sigma, *df, *r); /*if ( *ctyp==ewmaL ) cl = lns2ewmaL_crit(*l, *L0, *cu0, *hs, *sigma, *df, *r);*/ if ( *ctyp==ewma2 ) { if (*ltyp==fixed) { cl = lns2ewma2_crit_cufix(*l, *cu0, *L0, *hs, *sigma, *df, *r); cu = *cu0; } if ( *ltyp==unbiased ) result = lns2ewma2_crit_unbiased(*l, *L0, &cl, &cu, *hs, *sigma, *df, *r); /*if ( *ltyp==eqtails ) result = lns2ewma2_crit_eqtails(*l, *L0, &cl, &cu, *hs, *sigma, *df, *r);*/ if ( *ltyp==sym ) { cl = lns2ewma2_crit_sym(*l, *L0, *hs, *sigma, *df, *r); cu = 2*mitte - cl; } } if ( result != 0 ) warning("trouble with lns2ewma2_crit_unbiased called from lns2ewma_crit [package spc]"); c_values[0] = cl; c_values[1] = cu; } spc/src/sewma_q_crit.c0000644000175100001440000000455112655133155014500 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 #define fixed 0 #define unbiased 1 #define classic 2 double seU_q_crit(double l, int L0, double alpha, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); /*double se2lu_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error);*/ double se2fu_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); int se2_q_crit(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); int se2_q_crit_class(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm, double c_error, double a_error); double seUR_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); double seLR_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); void sewma_q_crit ( int *ctyp, int *ltyp, double *l, int *L0, double *alpha, double *cl0, double *cu0, double *hs, double *sigma, int *df, int *r, int *qm, double *ur, double *c_error, double *a_error, double *c_values) { int result=0; double cl=0., cu=1.; if ( *ctyp==ewmaU ) { cu = seU_q_crit(*l, *L0, *alpha, *hs, *sigma, *df, *r, *qm, *c_error, *a_error); cl = 0.; } if ( *ctyp==ewmaUR ) { cu = seUR_q_crit(*l, *L0, *alpha, *cl0, *hs, *sigma, *df, *r, *qm, *c_error, *a_error); cl = *cl0; } if ( *ctyp==ewmaLR ) { cl = seLR_q_crit(*l, *L0, *alpha, *cu0, *hs, *sigma, *df, *r, *qm, *c_error, *a_error); cu = *cu0; } if ( *ctyp==ewma2 ) { if ( *ltyp==fixed ) { cl = se2fu_q_crit(*l, *L0, *alpha, *cu0, *hs, *sigma, *df, *r, *qm, *c_error, *a_error); cu = *cu0; } if ( *ltyp==unbiased ) result = se2_q_crit(*l, *L0, *alpha, &cl, &cu, *hs, *sigma, *df, *r, *qm, *c_error, *a_error); if ( *ltyp==classic ) result = se2_q_crit_class(*l, *L0, *alpha, &cl, &cu, *hs, *sigma, *df, *ur, *r, *qm, *c_error, *a_error); } if ( result != 0 ) warning("trouble with se2_crit called from sewma_q_crit [package spc]"); c_values[0] = cl; c_values[1] = cu; } spc/src/xewma_sf_prerun.c0000644000175100001440000001212112655133155015217 0ustar hornikusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define stat 5 #define MU 0 #define SIGMA 1 #define BOTH 2 double *vector (long n); double xe2_sf_prerun_MU_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sf_prerun_MU(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double *p0); double xe2_sf_prerun_SIGMA_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sf_prerun_SIGMA(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double *p0); double xe2_sf_prerun_BOTH_deluxe(double l, double c, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double BOUND, double *p0); double xe2_sf_prerun_BOTH(double l, double c, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double *p0); double xe2_sfm_prerun_MU_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sfm_prerun_MU(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double *p0); double xe2_sfm_prerun_SIGMA_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sfm_prerun_SIGMA(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double *p0); double xe2_sfm_prerun_BOTH_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double BOUND, double *p0); double xe2_sfm_prerun_BOTH(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double *p0); void xewma_sf_prerun ( int *ctyp, double *l, double *c, double *zr, double *hs, double *mu, int *ltyp, int *q, int *n, int *size, int *df, int *mode, int *qm1, int *qm2, double *truncate, int *tail_approx, double *bound, double *sf) { int i, result=0; double *p0; p0 = vector(*n); if ( *mode == MU ) { if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) { if ( *tail_approx ) result = xe2_sf_prerun_MU_deluxe(*l, *c, *hs, *mu, *size, *n, *qm1, *truncate, *bound, p0); else result = xe2_sf_prerun_MU(*l, *c, *hs, *mu, *size, *n, *qm1, *truncate, p0); } if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) { if ( *tail_approx ) result = xe2_sfm_prerun_MU_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm1, *truncate, *bound, p0); else result = xe2_sfm_prerun_MU(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm1, *truncate, p0); } if ( *ctyp==ewma2 && *ltyp>fix ) { if ( *tail_approx ) result = xe2_sfm_prerun_MU_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm1, *truncate, *bound, p0); else result = xe2_sfm_prerun_MU(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm1, *truncate, p0); } } if ( *mode == SIGMA ) { if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) { if ( *tail_approx ) result = xe2_sf_prerun_SIGMA_deluxe(*l, *c, *hs, *mu, *size, *n, *qm2, *truncate, *bound, p0); else result = xe2_sf_prerun_SIGMA(*l, *c, *hs, *mu, *size, *n, *qm2, *truncate, p0); } if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) { if ( *tail_approx ) result = xe2_sfm_prerun_SIGMA_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm2, *truncate, *bound, p0); else result = xe2_sfm_prerun_SIGMA(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm2, *truncate, p0); } if ( *ctyp==ewma2 && *ltyp>fix ) { if ( *tail_approx ) result = xe2_sfm_prerun_SIGMA_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm2, *truncate, *bound, p0); else result = xe2_sfm_prerun_SIGMA(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm2, *truncate, p0); } } if ( *mode == BOTH ) { if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) { if ( *tail_approx ) result = xe2_sf_prerun_BOTH_deluxe(*l, *c, *hs, *mu, *size, *df, *n, *qm1, *qm2, *truncate, *bound, p0); else result = xe2_sf_prerun_BOTH(*l, *c, *hs, *mu, *size, *df, *n, *qm1, *qm2, *truncate, p0); } if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) { if ( *tail_approx ) result = xe2_sfm_prerun_BOTH_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, *n, *qm1, *qm2, *truncate, *bound, p0); else result = xe2_sfm_prerun_BOTH(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, *n, *qm1, *qm2, *truncate, p0); } if ( *ctyp==ewma2 && *ltyp>fix ) { if ( *tail_approx ) result = xe2_sfm_prerun_BOTH_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, *n, *qm1, *qm2, *truncate, *bound, p0); else result = xe2_sfm_prerun_BOTH(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, *n, *qm1, *qm2, *truncate, p0); } } if ( result != 0 ) warning("\nSomething bad happened!\n\n"); for (i=0; i<*n; i++) sf[i] = p0[i]; } spc/src/xcusum_ad.c0000644000175100001440000000141012655133155014002 0ustar hornikusers#include #include #include #include #define cusum1 0 #define cusum2 1 #define cusumC 2 extern double rho0; double xc1_iglad (double k, double h, double mu0, double mu1, int N); double xc2_iglad (double k, double h, double mu0, double mu1, int N); double xc2_igladR(double k, double h, double mu0, double mu1, int r); double xcC_iglad (double k, double h, double mu0, double mu1, int N); void xcusum_ad ( int *ctyp, double *k, double *h, double *mu0, double *mu1, int *r, double *ad) { if (*ctyp==cusum1) *ad = xc1_iglad(*k,*h,*mu0,*mu1,*r); if (*ctyp==cusum2 && *r>0) *ad = xc2_iglad(*k,*h,*mu0,*mu1,*r); if (*ctyp==cusum2 && *r<0) *ad = xc2_igladR(*k,*h,*mu0,*mu1,-*r); if (*ctyp==cusumC) *ad = xcC_iglad(*k,*h,*mu0,*mu1,*r); } spc/src/xtewma_ad.c0000644000175100001440000000240312655133155013766 0ustar hornikusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define conditional 0 #define cyclical 1 extern double rho0; /* double xe2_iglad (double l, double c, double mu0, double mu1, int N); double xe2_igladc(double l, double c, double mu0, double mu1, double z0, int N); double xe2_arlm (double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax);*/ double xte2_iglad(double l, double c, int df, double mu0, double mu1, int N, int subst); double xte2_igladc(double l, double c, int df, double mu0, double mu1, double z0, int N, int subst); double xte2_arlm (double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst); void xtewma_ad(int *ctyp, double *l, double *c, double *zr, int *df, double *mu0, double *mu1, double *z0, int *ltyp, int *styp, int *r, int *ntyp, double *ad) { int nmax=1000000; if ( *styp==conditional ) { if ( *ctyp==ewma2 && *ltyp==fix ) *ad = xte2_iglad(*l,*c,*df,*mu0,*mu1,*r,*ntyp); if ( *ctyp==ewma2 && *ltyp>fix ) *ad = xte2_arlm(*l,*c,0.,*df,200,*mu0,*mu1,*ltyp,*r,nmax,*ntyp); } else { if ( *ctyp==ewma2 && *ltyp==fix ) *ad = xte2_igladc(*l,*c,*df,*mu0,*mu1,*z0,*r,*ntyp); } } spc/src/xtewma_q.c0000644000175100001440000000214412655133155013644 0ustar hornikusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 /*double xe1_Wq(double l, double c, double p, double zr, double hs, double mu, int N, int nmax); double xe1_Wqm(double l, double c, double p, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax);*/ double xte2_Wq(double l, double c, double p, double hs, int df, double mu, int N, int nmax, int subst); double xte2_Wqm(double l, double c, double p, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst); void xtewma_q(int *ctyp, double *l, double *c, double *p, double *zr, double *hs, int *df, double *mu, int *ltyp, int *r, int *ntyp, int *q, double *tq) { int nmax=1000000; if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xte2_Wq(*l, *c, *p, *hs, *df, *mu, *r, nmax, *ntyp); if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xte2_Wqm(*l, *c, *p, *hs, *df, *q, 0., *mu, *ltyp, *r, nmax, *ntyp); if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xte2_Wqm(*l, *c, *p, *hs, *df, *q, 0., *mu, *ltyp, *r, nmax, *ntyp); } spc/src/xcusum_arl.c0000644000175100001440000000272012655133155014201 0ustar hornikusers#include #include #include #include #define cusum1 0 #define cusum2 1 #define cusumC 2 #define igl 0 #define mc 1 extern double rho0; double *vector (long n); double xc1_iglarl(double k, double h, double hs, double mu, int N); double xc1_arlm(double k, double h, double hs, int q, double mu0, double mu1, int N, int nmax); double xc1_arlm_hom(double k, double h, double hs, int q, double mu0, double mu1, int N, double *ced); double xc2_iglarl(double k, double h, double hs, double mu, int N); double xc2_be_arl(double k, double h, double hs1, double hs2, double mu, int N); double xcC_iglarl(double k, double h, double hs, double mu, int N); void xcusum_arl ( int *ctyp, double *k, double *h, double *hs, double *mu, int *q, int *r, int *method, double *arl) { int i, /*nmax=100000,*/ result=0; double lhs, *ced, arl1=-1.; ced = vector(*q); if ( *ctyp == cusum1 && *q==1 ) arl1 = xc1_iglarl(*k,*h,*hs,*mu,*r); if ( *ctyp == cusum1 && *q>1 ) result = xc1_arlm_hom(*k, *h, *hs, *q, 0., *mu, *r, ced); /* *arl = xc1_arlm(*k, *h, *hs, *q, 0., *mu, *r, nmax); */ if ( *ctyp == cusum2 ) { if ( *method == igl ) arl1 = xc2_iglarl(*k,*h,*hs,*mu,*r); lhs = - *hs; if ( *method == mc ) arl1 = xc2_be_arl(*k,*h,*hs,lhs,*mu,*r); } if ( *ctyp == cusumC ) arl1 = xcC_iglarl(*k,*h,*hs,*mu,*r); if ( result != 0 ) warning("trouble in xgrsr_arl [package spc]"); if ( *q > 1 ) for (i=0; i<*q; i++) arl[i] = ced[i]; else *arl = arl1; } spc/src/ewma_phat_crit_coll.c0000644000175100001440000000134512655133155016020 0ustar hornikusers#include #include #include #include double ewma_phat_crit(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm); double ewma_phat_crit2(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M); void ewma_phat_crit_coll (double *lambda, double *L0, double *mu, double *sigma, int *n, double *z0, int *ctyp, double *LSL, double *USL, int *N, int *qm, double *ucl) { int M=4; *ucl = -1.; if ( *ctyp == 0 ) *ucl = ewma_phat_crit(*lambda, *L0, *mu, *sigma, *n, *z0, *LSL, *USL, *N, *qm); if ( *ctyp == 1 ) *ucl = ewma_phat_crit2(*lambda, *L0, *mu, *sigma, *n, *z0, *LSL, *USL, *N, *qm, M); } spc/src/tol_lim_fac.c0000644000175100001440000000055612655133155014274 0ustar hornikusers#include #include #include #include #define WW 0 #define exact 1 double kww(int n, double p, double a); double tl_factor(int n, double p, double a, int m); void tol_lim_fac(int *n, double *p, double *a, int *mtype, int *m, double *tlf ) { if (*mtype==WW) *tlf = kww(*n,*p,*a); else *tlf = tl_factor(*n,*p,*a,*m); } spc/src/ewma_p_arl_be.c0000644000175100001440000000065012655133155014573 0ustar hornikusers#include #include #include #include double ewma_p_arl(double lambda, double ucl, int n, double p, double z0, int d_res, int round_mode, int mid_mode); void ewma_p_arl_be (double *lambda, double *ucl, int *n, double *p, double *z0, int *d_res, int *round_mode, int *mid_mode, double *arl) { *arl = -1.; *arl = ewma_p_arl(*lambda, *ucl, *n, *p, *z0, *d_res, *round_mode, *mid_mode); } spc/src/xewma_arl_prerun.c0000644000175100001440000000473612655133155015402 0ustar hornikusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define stat 5 #define MU 0 #define SIGMA 1 #define BOTH 2 double xe2_iglarl_prerun_MU(double l, double c, double hs, double mu, int pn, int qm, double truncate); double xe2_iglarl_prerun_SIGMA(double l, double c, double hs, double mu, int pn, int qm, double truncate); double xe2_iglarl_prerun_BOTH(double l, double c, double hs, double mu, int pn, int df, int qm1, int qm2, double truncate); double xe2_arlm_prerun_MU(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate); double xe2_arlm_prerun_SIGMA(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate); double xe2_arlm_prerun_BOTH(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate); void xewma_arl_prerun ( int *ctyp, double *l, double *c, double *zr, double *hs, double *mu, int *ltyp, int *q, int *size, int *df, int *mode, int *qm1, int *qm2, double *truncate, double *arl) { int nmax = 100000; if ( *mode == MU ) { if (*ctyp==ewma2 && *ltyp==fix && *q==1) *arl = xe2_iglarl_prerun_MU(*l, *c, *hs, *mu, *size, *qm1, *truncate); if (*ctyp==ewma2 && *ltyp==fix && *q>1) *arl = xe2_arlm_prerun_MU(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm1, *truncate); if (*ctyp==ewma2 && *ltyp>fix) *arl = xe2_arlm_prerun_MU(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm1, *truncate); } if ( *mode == SIGMA ) { if (*ctyp==ewma2 && *ltyp==fix && *q==1) *arl = xe2_iglarl_prerun_SIGMA(*l, *c, *hs, *mu, *size, *qm2, *truncate); if (*ctyp==ewma2 && *ltyp==fix && *q>1) *arl = xe2_arlm_prerun_SIGMA(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm2, *truncate); if (*ctyp==ewma2 && *ltyp>fix) *arl = xe2_arlm_prerun_SIGMA(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm2, *truncate); } if ( *mode == BOTH ) { if (*ctyp==ewma2 && *ltyp==fix && *q==1) *arl = xe2_iglarl_prerun_BOTH(*l, *c, *hs, *mu, *size, *df, *qm1, *qm2, *truncate); if (*ctyp==ewma2 && *ltyp==fix && *q>1) *arl = xe2_arlm_prerun_BOTH(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, nmax, *qm1, *qm2, *truncate); if (*ctyp==ewma2 && *ltyp>fix) *arl = xe2_arlm_prerun_BOTH(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, nmax, *qm1, *qm2, *truncate); } } spc/src/mewma_psi.c0000644000175100001440000000150312655133155013776 0ustar hornikusers#include #include #include #include #define cond 0 #define cycl 1 double *vector (long n); double mxewma_psi (double lambda, double ce, int p, int N, double *PSI, double *w, double *z); double mxewma_psiS(double lambda, double ce, int p, double hs, int N, double *PSI, double *w, double *z); void mewma_psi(double *l, double *c, int *p, int *type, double *hs, int *r, double *zeug) { double *PSI, *w, *z, zahl=0.; int i; PSI = vector(*r); w = vector(*r); z = vector(*r); if ( *type == cond ) zahl = mxewma_psi (*l, *c, *p, *r, PSI, w, z); if ( *type == cycl ) zahl = mxewma_psiS(*l, *c, *p, *hs, *r, PSI, w, z); zeug[0] = zahl; for (i = 1; i <= *r; i++) { zeug[i] = PSI[i-1]; zeug[i + *r] = w[i-1]; zeug[i + *r + *r] = z[i-1]; } Free(z); Free(w); Free(PSI); } spc/src/mewma_arl_f.c0000644000175100001440000001354212655133155014274 0ustar hornikusers#include #include #include #include #define GL 0 #define CO 1 #define RA 2 #define CC 3 #define MC 4 #define SR 5 #define CO2 6 #define GL2 7 #define GL3 8 #define GL4 9 #define GL5 10 #define CO3 11 #define CO4 12 double mxewma_arl_f_0a(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0a2(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0b(double lambda, double ce, int p, int N, int qm, double *ARL); double mxewma_arl_f_0c(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0d(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0e(double lambda, double ce, int p, int N, double *ARL, double *z); double mxewma_arl_f_0f(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_1a (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL class */ double mxewma_arl_f_1a2(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL mod */ double mxewma_arl_f_1a3(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod sin, default for 2 and 4 */ double mxewma_arl_f_1a4(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod tan */ double mxewma_arl_f_1a5(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod sinh, default for all other p */ double mxewma_arl_f_1b (double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step + sin() */ double mxewma_arl_f_1b3(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step */ double mxewma_arl_f_1b2(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with shrinked supports of the outer integral */ double mxewma_arl_f_1b4(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step + sinh() instead of sin() */ double mxewma_arl_f_1c (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL + Radau (Rigdon) */ double mxewma_arl_f_1d (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* Clenshaw-Curtis */ double mxewma_arl_f_1e (double lambda, double ce, int p, double delta, int N, double *g, int *dQ); /* Markov Chain (Runger/Prabhu) */ double mxewma_arl_f_1f (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z); /* Simpson rule */ double *vector (long n); void mewma_arl_f(double *l, double *c, int *p, double *delta, int *r, int *qtype, int *qm0, int *qm1, double *zeug) { double *ARL, *w, *z, *w1, *z1, zahl=0.; int i, j, r2, dQ; if ( fabs(*delta)<1e-10 ) { ARL = vector(*r); w = vector(*r); z = vector(*r); for (i = 0; i < *r; i++) { w[i] = -1.; z[i] = 0.; } /* init */ if ( *qtype == GL ) zahl = mxewma_arl_f_0a (*l, *c, *p, *r, ARL, w, z); if ( *qtype == GL2 ) zahl = mxewma_arl_f_0a2(*l, *c, *p, *r, ARL, w, z); if ( *qtype == CO ) zahl = mxewma_arl_f_0b (*l, *c, *p, *r, *qm0, ARL); if ( *qtype == RA ) zahl = mxewma_arl_f_0c (*l, *c, *p, *r, ARL, w, z); if ( *qtype == CC ) zahl = mxewma_arl_f_0d (*l, *c, *p, *r, ARL, w, z); if ( *qtype == MC ) zahl = mxewma_arl_f_0e (*l, *c, *p, *r, ARL, z); if ( *qtype == SR ) zahl = mxewma_arl_f_0f (*l, *c, *p, *r, ARL, w, z); for (i = 0; i < *r; i++) { zeug[i] = ARL[i]; zeug[i + *r] = w[i]; zeug[i + *r + *r] = z[i]; } Free(z); Free(w); Free(ARL); } else { r2 = (*r) * (*r); ARL = vector(r2); w = vector(*r); z = vector(*r); w1 = vector(*r); z1 = vector(*r); if ( *qtype == GL ) zahl = mxewma_arl_f_1a (*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == GL2 ) zahl = mxewma_arl_f_1a2(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == GL3 ) zahl = mxewma_arl_f_1a3(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == GL4 ) zahl = mxewma_arl_f_1a4(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == GL5 ) zahl = mxewma_arl_f_1a5(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == CO ) zahl = mxewma_arl_f_1b (*l, *c, *p, *delta, *r, *qm0, *qm1, ARL); if ( *qtype == CO2 ) zahl = mxewma_arl_f_1b2(*l, *c, *p, *delta, *r, *qm0, *qm1, ARL); if ( *qtype == CO3 ) zahl = mxewma_arl_f_1b3(*l, *c, *p, *delta, *r, *qm0, *qm1, ARL); if ( *qtype == CO4 ) zahl = mxewma_arl_f_1b4(*l, *c, *p, *delta, *r, *qm0, *qm1, ARL); if ( *qtype == RA ) zahl = mxewma_arl_f_1c(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == CC ) zahl = mxewma_arl_f_1d(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == MC ) zahl = mxewma_arl_f_1e(*l, *c, *p, *delta, *r, zeug, &dQ); if ( *qtype == SR ) zahl = mxewma_arl_f_1f(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype != MC ) { for (i = 0; i < *r; i++) { for (j = 0; j < *r; j++) zeug[ i*(*r) + j ] = ARL[ i*(*r) + j ]; zeug[i + r2] = w[i]; zeug[i + r2 + *r] = z[i]; zeug[i + r2 + 2*(*r)] = w1[i]; zeug[i + r2 + 3*(*r)] = z1[i]; } } /*else { printf("\n\ndQ = %d\n\n", dQ); for (i=0; i < dQ; i++) zeug[i] = ARL[i]; } */ Free(z1); Free(w1); Free(z); Free(w); Free(ARL); } if ( fabs(zahl) > 1e-9 ) warning("trouble in mewma_arl_f [package spc]"); } spc/src/xewma_res_arl.c0000644000175100001440000000054712655133155014654 0ustar hornikusers#include #include #include #include double xe2_iglarl_RES(double l, double c, double hs, double mu, int N, double alpha, int df); void x_res_ewma_arl(double *alpha, int *n, int *ctyp, double *l, double *c, double *hs, double *mu, int *r, double *arl) { *arl = -1.; *arl = xe2_iglarl_RES(*l,*c,*hs,*mu,*r,*alpha,*n); } spc/src/xshewhart_ar1_arl.c0000644000175100001440000000047412655133155015441 0ustar hornikusers#include #include #include #include double x_shewhart_ar1_arl(double alpha, double cS, double delta, int N1, int N2); void xshewhart_ar1_arl(double *alpha, double *cS, double *delta, int *N1, int *N2, double *arl) { *arl = x_shewhart_ar1_arl(*alpha, *cS, *delta, *N1, *N2); } spc/src/xcusum_q.c0000644000175100001440000000055412655133155013666 0ustar hornikusers#include #include #include #include #define cusum1 0 #define cusum2 1 double xc1_Wq(double k, double h, double p, double hs, double mu, int N, int nmax); void xcusum_q(int *ctyp, double *k, double *h, double *p, double *hs, double *mu, int *r, double *q) { if (*ctyp==cusum1) *q = xc1_Wq(*k, *h, *p, *hs, *mu, *r, 10000); } spc/src/sewma_sf_prerun.c0000644000175100001440000000552012655133155015217 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 double *vector (long n); double seU_sf_prerun_SIGMA_deluxe(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seU_sf_prerun_SIGMA(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seUR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seUR_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double se2_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double se2_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seLR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seLR_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); void sewma_sf_prerun ( int *ctyp, double *l, double *cl, double *cu, double *hs, double *sigma, int *df1, int *qm1, int *n, int *df2, int *qm2, double *truncate, int *tail_approx, double *sf) { int result=0, i; double *p0; p0 = vector(*n); if ( *ctyp == ewmaU ) { if ( *tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(*l, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); else result = seU_sf_prerun_SIGMA(*l, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); } if ( *ctyp == ewmaUR ) { if ( *tail_approx ) result = seUR_sf_prerun_SIGMA_deluxe(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); else result = seUR_sf_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); } if ( *ctyp == ewma2 ) { if ( *tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); else result = se2_sf_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); } if ( *ctyp == ewmaLR ) { if ( *tail_approx ) result = seLR_sf_prerun_SIGMA_deluxe(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); else result = seLR_sf_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); } if ( result != 0 ) warning("trouble in sewma_sf_prerun [package spc]"); for (i=0; i<*n; i++) sf[i] = p0[i]; } spc/src/xewma_crit.c0000644000175100001440000000061012655133155014155 0ustar hornikusers#include #include #include #include extern double rho0; double xe_crit(int ctyp, double l, double L0, double zr, double hs, double m0, int ltyp, int N, double c0); void xewma_crit(int *ctyp, double *l, double *L0, double *zr, double *hs, double *mu0, int *ltyp, int *r, double *c0, double *h) { *h = xe_crit(*ctyp,*l,*L0,*zr,*hs,*mu0,*ltyp,*r,*c0); } spc/src/xsewma_arl.c0000644000175100001440000000162312655133155014162 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 double xseU_arl (double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); double xse2_arl (double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); void xsewma_arl ( int *ctyp, double *lx, double *cx, double *hsx, int *Nx, double *ls, double *csl, double *csu, double *hss, int *Ns, double *mu, double *sigma, int *df, int *qm, int *s_squared, double *arl) { *arl = -1.; if (*ctyp==ewmaU) *arl = xseU_arl(*lx,*ls,*cx,*csu,*hsx,*hss,*mu,*sigma,*df,*Nx,*Ns,10000,*qm); if (*ctyp==ewma2) *arl = xse2_arl(*lx,*ls,*cx,*csl,*csu,*hsx,*hss,*mu,*sigma,*df,*Nx,*Ns,10000,*qm); } spc/src/sewma_sf.c0000644000175100001440000000245612655133155013631 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 double *vector (long n); double seU_sf(double l, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); double se2_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); double seUR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); double seLR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); void sewma_sf ( int *ctyp, double *l, double *cl, double *cu, double *hs, int *N, double *sigma, int *df, int *qm, int *n, double *sf) { int result=0, i; double *p0; p0 = vector(*n); if ( *ctyp == ewmaU ) result = seU_sf(*l, *cu, *hs, *sigma, *df, *N, *n, *qm, p0); if ( *ctyp == ewmaUR ) result = seUR_sf(*l, *cl, *cu, *hs, *sigma, *df, *N, *n, *qm, p0); if ( *ctyp == ewma2 ) result = se2_sf(*l, *cl, *cu, *hs, *sigma, *df, *N, *n, *qm, p0); if ( *ctyp == ewmaLR ) result = seLR_sf(*l, *cl, *cu, *hs, *sigma, *df, *N, *n, *qm, p0); if ( result != 0 ) warning("trouble in sewma_sf [package spc]"); for (i=0; i<*n; i++) sf[i] = p0[i]; Free(p0); } spc/src/xDgrsr_arl.c0000644000175100001440000000163212655133155014127 0ustar hornikusers#include #include #include #include #define grsr1 0 #define grsr2 1 #define Gan 0 #define Knoth 1 extern double rho0; double xsr1_iglarl_drift(double k, double h, double zr, double hs, double delta, int m, int N, int with0); double xsr1_iglarl_drift_wo_m(double k, double h, double zr, double hs, double delta, int *m, int N, int with0); double xsr1_iglarlm_drift(double k, double h, double zr, double hs, int q, double delta, int N, int nmax, int with0); void xDgrsr_arl ( double *k, double *h, double *zr, double *hs, double *delta, int *m, int *r, int *with0, int *mode, int *q, double *arl) { if (*m>0) *arl = xsr1_iglarl_drift(*k, *h, *zr, *hs, *delta, *m, *r, *with0); if (*m==0 && *mode==Gan) *arl = xsr1_iglarl_drift_wo_m(*k, *h, *zr, *hs, *delta, m, *r, *with0); if (*m==0 && *mode==Knoth) *arl = xsr1_iglarlm_drift(*k, *h, *zr, *hs, *q, *delta, *r, 10000, *with0); } spc/src/sewma_q_prerun.c0000644000175100001440000000275712655133155015060 0ustar hornikusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 double seU_Wq_prerun_SIGMA_deluxe(double l, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); double seUR_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); double seLR_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); double se2_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); void sewma_q_prerun ( int *ctyp, double *l, double *cl, double *cu, double *p, double *hs, double *sigma, int *df1, int *r, int *qm1, int *df2, int *qm2, double *truncate, double *tq) { int nmax=100000; if ( *ctyp == ewmaU ) *tq = seU_Wq_prerun_SIGMA_deluxe(*l, *cu, *p, *hs, *sigma, *df1, *df2, nmax, *qm1, *qm2, *truncate); if ( *ctyp == ewma2 ) *tq = se2_Wq_prerun_SIGMA_deluxe(*l, *cl, *cu, *p, *hs, *sigma, *df1, *df2, nmax, *qm1, *qm2, *truncate); if ( *ctyp == ewmaUR ) *tq = seUR_Wq_prerun_SIGMA_deluxe(*l, *cl, *cu, *p, *hs, *sigma, *df1, *df2, nmax, *qm1, *qm2, *truncate); if ( *ctyp == ewmaLR ) *tq = seLR_Wq_prerun_SIGMA_deluxe(*l, *cl, *cu, *p, *hs, *sigma, *df1, *df2, nmax, *qm1, *qm2, *truncate); } spc/src/mewma_ad.c0000644000175100001440000000067212655133155013575 0ustar hornikusers#include #include #include #include double mxewma_ad (double lambda, double ce, int p, double delta, int N, int qm2, int psi_type, double hs, int qtype, int qm0, int qm1); void mewma_ad(double *l, double *c, int *p, double *delta, int *r, int *qm2, int *ptype, double *hs, int *qtype, int *qm0, int *qm1, double *ad) { *ad = mxewma_ad(*l, *c, *p, *delta, *r, *qm2, *ptype, *hs, *qtype, *qm0, *qm1); } spc/NAMESPACE0000644000175100001440000000261612655121326012304 0ustar hornikusersuseDynLib(spc) ## imports import("stats") ## exports export("xshewhartrunsrules.ad", "xshewhartrunsrules.arl", "xshewhartrunsrules.crit", "xshewhartrunsrules.matrix", "xshewhart.ar1.arl", "xewma.ad", "xewma.arl", "xewma.crit", "xewma.q", "xewma.sf", "xewma.q.crit", "xcusum.ad", "xcusum.arl", "xcusum.crit.L0h", "xcusum.crit.L0L1", "xcusum.crit", "xcusum.q", "xcusum.sf", "xgrsr.ad", "xgrsr.arl", "xgrsr.crit", "sewma.arl", "sewma.crit", "sewma.sf", "sewma.q.crit", "sewma.q", "sewma.sf.prerun", "sewma.arl.prerun", "sewma.q.crit.prerun", "sewma.q.prerun", "sewma.crit.prerun", "lns2ewma.arl", "lns2ewma.crit", "scusum.arl", "scusum.crit", "mewma.arl", "mewma.crit", "mewma.psi", "mewma.arl.f", "mewma.ad", "xsewma.arl", "xsewma.crit", "xsewma.sf", "xsewma.q.crit", "xsewma.q", "xewma.arl.prerun", "xewma.q.prerun", "xewma.sf.prerun", "xewma.crit.prerun", "xewma.q.crit.prerun", "xtewma.arl", "xtewma.ad", "xtewma.sf", "xtewma.q", "xtewma.q.crit", "xtcusum.arl", "xDcusum.arl", "xDewma.arl", "xDgrsr.arl", "xDshewhartrunsrules.arl", "xDshewhartrunsrulesFixedm.arl", "p.ewma.arl", "phat.ewma.arl", "phat.ewma.crit", "phat.ewma.lambda", "dphat", "pphat", "qphat", "s.res.ewma.arl", "x.res.ewma.arl", "xs.res.ewma.arl", "xs.res.ewma.pms", "quadrature.nodes.weights", "tol.lim.fac") spc/R/0000755000175100001440000000000012655113035011257 5ustar hornikusersspc/R/sewma.q.crit.prerun.R0000644000175100001440000000434612053677210015240 0ustar hornikusers# Computation of EWMA critical values for given QRL (variance monitoring) with pre-run uncertainty sewma.q.crit.prerun <- function(l, L0, alpha, df1, df2, sigma0=1, cl=NULL, cu=NULL, hs=1, sided="upper", mode="fixed", r=40, qm=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE, c.error=1e-10, a.error=1e-9) { cu0 <- cl0 <- 0 if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( L0<1 ) stop("L0 is too small") if ( alpha<=0 | alpha>=1 ) stop("quantile level alpha must be in (0,1)") if ( df1<1 ) stop("df1 must be positive") if ( df2<1 ) stop("df2 must be positive") if ( sigma0<=0 ) stop("sigma0 must be positive") if ( sided=="Rupper" ) { if ( is.null(cl) ) stop("set cl") if ( cl<=0 ) stop("cl must be positive") cl0 <- cl if ( hs= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") c <- .C("sewma_q_crit_prerun", as.integer(ctyp), as.integer(ltyp), as.double(l), as.integer(L0), as.double(alpha), as.double(cl0), as.double(cu0), as.double(hs), as.double(sigma0), as.integer(df1), as.integer(r), as.integer(qm), as.integer(df2), as.integer(qm.sigma), as.double(truncate), as.integer(tail_approx), as.double(c.error), as.double(a.error), ans=double(length=2),PACKAGE="spc")$ans names(c) <- c("cl", "cu") return (c) } spc/R/xshewhartrunsrules.matrix.R0000644000175100001440000001206011174121634016703 0ustar hornikusers xshewhartrunsrules.matrix <- function(mu, c=1, type="12") { # Shewhart chart if (type=="1") { p0 <- pnorm( 3*c, mean=mu ) - pnorm( -3*c, mean=mu) Q <- p0 } # 2 of 3 beyond +-2 sigma if (type=="12") { dimQ <- 7 pl <- pnorm( -2*c, mean=mu ) - pnorm( -3*c, mean=mu) p0 <- pnorm( 2*c, mean=mu ) - pnorm( -2*c, mean=mu) pr <- pnorm( 3*c, mean=mu ) - pnorm( 2*c, mean=mu) # 1 2 3 4 5 6 7 # 0000 1000 0100 0010 0001 1001 0110 # 1 0000 p0 pl 0 pr 0 0 0 # 2 1000 0 0 p0 0 0 0 pr # 3 0100 p0 0 0 pr 0 0 0 # 4 0010 0 0 0 0 p0 pl 0 # 5 0001 p0 pl 0 0 0 0 0 # 6 1001 0 0 p0 0 0 0 0 # 7 0110 0 0 0 0 p0 0 0 Q <- diag(0,dimQ) Q[1,2] <- pl; Q[1,1] <- p0; Q[1,4] <- pr Q[2,3] <- p0; Q[2,7] <- pr Q[3,1] <- p0; Q[3,4] <- pr Q[4,6] <- pl; Q[4,5] <- p0 Q[5,2] <- pl; Q[5,1] <- p0 Q[6,3] <- p0 Q[7,5] <- p0 } # 4 of 5 beyond +-1 sigma if (type=="13") { dimQ <- 29 pl <- pnorm( -c, mean=mu ) - pnorm( -3*c, mean=mu) p0 <- pnorm( c, mean=mu ) - pnorm( -c, mean=mu) pr <- pnorm( 3*c, mean=mu ) - pnorm( c, mean=mu) Q <- diag(0,dimQ) Q[ 1, 2] <- pl; Q[ 1, 1] <- p0; Q[ 1,11] <- pr Q[ 2, 4] <- pl; Q[ 2, 3] <- p0; Q[ 2,12] <- pr Q[ 3, 5] <- pl; Q[ 3, 1] <- p0; Q[ 3,11] <- pr Q[ 4, 7] <- pl; Q[ 4, 6] <- p0; Q[ 4,13] <- pr Q[ 5, 8] <- pl; Q[ 5, 3] <- p0; Q[ 5,12] <- pr Q[ 6, 9] <- pl; Q[ 6, 1] <- p0; Q[ 6,11] <- pr Q[ 7,10] <- p0; Q[ 7,14] <- pr Q[ 8, 6] <- p0; Q[ 8,13] <- pr Q[ 9, 3] <- p0; Q[ 9,12] <- pr Q[10, 1] <- p0; Q[10,11] <- pr Q[11,16] <- pl; Q[11,15] <- p0; Q[11,19] <- pr Q[12,17] <- pl; Q[12,15] <- p0; Q[12,19] <- pr Q[13,18] <- pl; Q[13,15] <- p0; Q[13,19] <- pr Q[14,15] <- p0; Q[14,19] <- pr Q[15, 2] <- pl; Q[15, 1] <- p0; Q[15,20] <- pr Q[16, 4] <- pl; Q[16, 3] <- p0; Q[16,21] <- pr Q[17, 8] <- pl; Q[17, 3] <- p0; Q[17,21] <- pr Q[18, 3] <- p0; Q[18,21] <- pr Q[19,23] <- pl; Q[19,22] <- p0; Q[19,24] <- pr Q[20,16] <- pl; Q[20,15] <- p0; Q[20,25] <- pr Q[21,17] <- pl; Q[21,15] <- p0; Q[21,25] <- pr Q[22, 2] <- pl; Q[22, 1] <- p0; Q[22,26] <- pr Q[23, 4] <- pl; Q[23, 3] <- p0; Q[23,27] <- pr Q[24,29] <- pl; Q[24,28] <- p0 Q[25,23] <- pl; Q[25,22] <- p0 Q[26,16] <- pl; Q[26,15] <- p0 Q[27,17] <- pl; Q[27,15] <- p0 Q[28, 2] <- pl; Q[28, 1] <- p0 Q[29, 4] <- pl; Q[29, 3] <- p0 } # 8 on the same side if (type=="14") { dimQ <- 15 pl <- pnorm( 0, mean=mu ) - pnorm( -3*c, mean=mu) pr <- pnorm( 3*c, mean=mu ) - pnorm( 0, mean=mu) Q <- diag(0,dimQ) Q[ 1, 2] <- pl; Q[ 1, 9] <- pr Q[ 2, 3] <- pl; Q[ 2, 9] <- pr Q[ 3, 4] <- pl; Q[ 3, 9] <- pr Q[ 4, 5] <- pl; Q[ 4, 9] <- pr Q[ 5, 6] <- pl; Q[ 5, 9] <- pr Q[ 6, 7] <- pl; Q[ 6, 9] <- pr Q[ 7, 8] <- pl; Q[ 7, 9] <- pr Q[ 8, 9] <- pr Q[ 9, 2] <- pl; Q[ 9,10] <- pr Q[10, 2] <- pl; Q[10,11] <- pr Q[11, 2] <- pl; Q[11,12] <- pr Q[12, 2] <- pl; Q[12,13] <- pr Q[13, 2] <- pl; Q[13,14] <- pr Q[14, 2] <- pl; Q[14,15] <- pr Q[15, 2] <- pl; } # ... on the same side (general approach) if ( regexpr("SameSide", type)>0 ) { anzahl <- as.numeric(gsub("SameSide", "", type)) dimQ <- 2*anzahl - 1 hdQ <- anzahl - 1 pl <- pnorm( 0, mean=mu ) - pnorm( -3*c, mean=mu) pr <- pnorm( 3*c, mean=mu ) - pnorm( 0, mean=mu) Q <- diag(0, dimQ) for ( i in 1:hdQ ) { Q[i,i+1] <- pl Q[hdQ+i+1,2] <- pl Q[i,hdQ+2] <- pr Q[hdQ+i,hdQ+i+1] <- pr } } # 2 of 2 beyond +-2 sigma if (type=="15") { dimQ <- 3 pl <- pnorm( -2*c, mean=mu ) - pnorm( -3*c, mean=mu) p0 <- pnorm( 2*c, mean=mu ) - pnorm( -2*c, mean=mu) pr <- pnorm( 3*c, mean=mu ) - pnorm( 2*c, mean=mu) # 1 2 3 # 00 10 01 # 1 00 p0 pr pl # 2 10 p0 0 pl # 3 01 p0 pr 0 Q <- diag(0,dimQ) Q[1,2] <- pl; Q[1,1] <- p0; Q[1,3] <- pr Q[2,1] <- p0; Q[2,3] <- pr Q[3,2] <- pl; Q[3,1] <- p0; } # 3 of 3 beyond +-3 sigma if (type=="19") { dimQ <- 5 pl <- pnorm( -3*c, mean=mu ) p0 <- pnorm( 3*c, mean=mu ) - pnorm( -3*c, mean=mu) pr <- 1 - pnorm( 3*c, mean=mu) # 1 2 3 4 5 # 0000 1000 1100 0010 0011 # 1 0000 p0 pr 0 pl 0 # 2 1000 p0 0 pr pl 0 # 3 1100 p0 0 0 pl 0 # 4 0010 p0 pr 0 0 pl # 5 0011 p0 pr 0 0 0 Q <- diag(0,dimQ) Q[1,4] <- pl; Q[1,1] <- p0; Q[1,2] <- pr Q[2,4] <- pl; Q[2,1] <- p0; Q[2,3] <- pr Q[3,4] <- pl; Q[3,1] <- p0; Q[4,5] <- pl; Q[4,1] <- p0; Q[4,2] <- pr Q[5,1] <- p0; Q[5,2] <- pr } Q }spc/R/xewma.crit.R0000644000175100001440000000212512536537100013464 0ustar hornikusers# Computation of EWMA critical values for given ARL (mean monitoring) xewma.crit <- function(l,L0,mu0=0,zr=0,hs=0,sided="one",limits="fix",r=40,c0=NULL) { if ( l<=0 | l>2 ) stop("l has to be between 0 and 2") if ( L0<1 ) stop("L0 is too small") if ( r<4 ) stop("r is too small") if ( sided=="one" & hs1 ) stop("l has to be between 0 and 1") if ( L0<1 ) stop("L0 is too small") if ( df<1 ) stop("df must be positive") if ( sigma0<=0 ) stop("sigma0 must be positive") if ( sided=="upper" ) { if ( is.null(cl) ) cl <- mitte #if ( cl > mitte + 1e-9 ) stop(paste("cl has to be smaller than", mitte)) cl0 <- cl if ( hscu0+1e-9 ) stop("hs must not be larger than cu") } if (sided=="two" & mode=="fixed") { if ( is.null(cu) ) stop("set cu") #if ( cu < mitte - 1e-9 ) stop(paste("cu has to be larger than", mitte)) cu0 <- cu if ( hs>cu0+1e-9 ) stop("hs must not be larger than cu") } ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1 if (is.na(ctyp)) stop("invalid ewma type") ltyp <- pmatch(mode, c("fixed", "unbiased", "eq.tails", "vanilla")) - 1 if (is.na(ltyp)) stop("invalid limits type") if ( r<10 ) stop("r is too small") c <- .C("lns2ewma_crit", as.integer(ctyp), as.integer(ltyp), as.double(l), as.double(L0), as.double(cl0), as.double(cu0), as.double(hs), as.double(sigma0), as.integer(df), as.integer(r), ans=double(length=2),PACKAGE="spc")$ans names(c) <- c("cl", "cu") return (c) } spc/R/dphat.R0000644000175100001440000000172112506046626012511 0ustar hornikusersdphat <- function(x, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30) { if ( n < 1 ) stop("n must be >= 1") if ( sigma<1e-10 ) stop("sigma much too small") ctyp <- -1 + pmatch(type, c("known", "estimated")) if ( is.na(ctyp) ) stop("invalid sigma mode") if ( LSL >= USL ) stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)") if ( nodes<2 ) stop("far too less nodes") p.star <- pnorm( LSL/sigma ) + pnorm( -USL/sigma ) if ( type == "estimated" ) p.star <- 0 pdf <- rep(NA, length(x)) for ( i in 1:length(x) ) { pdf[i] <- 0 if ( p.star 1 ) stop("l (lambda) has to be between 0 and 1") if ( c <= 0 ) warning("usually, c has to be positive") if ( n < 1 ) stop("n has to be a natural number") if ( zr > c & sided == "one") stop("wrong reflexion border") if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) ) warning("unusual headstart") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat", "test")) if (is.na(ltyp)) stop("invalid limits type") if ( (sided=="one") & !( limits %in% c("fix", "vacl", "stat") ) ) stop("not supported for one-sided EWMA (not reasonable or not implemented yet") if ( r < 4 ) stop("r is too small") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") sf <- .C("xewma_sf", as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.double(hs), as.double(mu), as.integer(ltyp), as.integer(r), as.integer(q), as.integer(n), ans=double(length=n),PACKAGE="spc")$ans names(sf) <- NULL sf } spc/R/sewma.sf.R0000644000175100001440000000204212052443142013117 0ustar hornikusers# Computation of EWMA survival function (variance monitoring) sewma.sf <- function(n, l, cl, cu, sigma, df, hs=1, sided="upper", r=40, qm=30) { if ( n < 1 ) stop("n has to be a natural number") if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1") if ( cu<=0 ) stop("cu has to be positive") if ( cl<0 ) stop("cl has to be non-negative") if ( sided!="upper" & cl<1e-6 ) stop("cl is too small") if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") if ( hscu ) stop("wrong headstart hs") if ( r<10 ) stop("r is too small") ctyp <- pmatch(sided, c("upper","Rupper","two","Rlower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") if ( qm<5 ) stop("qm is too small") sf <- .C("sewma_sf", as.integer(ctyp), as.double(l), as.double(cl), as.double(cu), as.double(hs), as.integer(r), as.double(sigma), as.integer(df), as.integer(qm), as.integer(n), ans=double(length=n),PACKAGE="spc")$ans names(sf) <- NULL sf } spc/R/qphat.R0000644000175100001440000000154212506046577012534 0ustar hornikusersqphat <- function(p, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30) { if ( n < 1 ) stop("n must be >= 1") if ( sigma<1e-10 ) stop("sigma much too small") ctyp <- -1 + pmatch(type, c("known", "estimated")) if ( is.na(ctyp) ) stop("invalid sigma mode") if ( LSL >= USL ) stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)") if ( nodes<2 ) stop("far too less nodes") qf <- rep(NA, length(p)) for ( i in 1:length(p) ) { qf[i] <- NA if ( 0= 1") if ( z0 < p.star & z0 >= 1 ) stop("wrong headstart") if ( sigma<1e-12 ) stop("sigma much too small") ctyp <- -1 + pmatch(type, c("known", "estimated")) if ( is.na(ctyp) ) stop("invalid sigma mode") if ( max_l < min_l | max_l > 1 ) stop("wrong value for max_l (or min_l)") if ( min_l < 1e-4 ) stop("min_l too small") if ( LSL >= USL ) stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)") if ( qm < 5 ) stop("qm too small") lambda <- .C("ewma_phat_lambda_coll", as.double(L0), as.double(mu), as.double(sigma), as.integer(ctyp), as.double(max_l), as.double(min_l), as.integer(n), as.double(z0), as.double(LSL), as.double(USL), as.integer(qm), ans=double(length=1), PACKAGE="spc")$ans names(lambda) <- "lambda" lambda }spc/R/xewma.arl.R0000644000175100001440000000300312536065214013277 0ustar hornikusers# Computation of EWMA ARLs (mean monitoring) xewma.arl <- function(l, c, mu, zr=0, hs=0, sided="one", limits="fix", q=1, r=40) { if ( l<=0 | l>2 ) stop("l has to be between 0 and 2") if ( c<=0 ) warning("usually, c has to be positive") if ( zr>c & sided=="one" ) stop("wrong reflexion border") if ( (sided=="two" & abs(hs)>c) | (sided=="one" & (hsc)) ) warning("unusual headstart") if ( r<4 ) stop("r is too small") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat", "fink", "limit", "fixW", "fixC")) if ( is.na(ltyp) ) stop("invalid limits type") if ( (sided=="one") & !(limits %in% c("fix", "vacl", "stat", "limit", "fixW")) ) stop("not supported for one-sided EWMA (not reasonable or not implemented yet") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") if ( limits=="fix" & q>1 ) { arl <- .C("xewma_arl",as.integer(ctyp),as.double(l), as.double(c),as.double(zr),as.double(hs), as.double(mu),as.integer(ltyp),as.integer(r),as.integer(q), ans=double(length=q), PACKAGE="spc")$ans } else { arl <- .C("xewma_arl",as.integer(ctyp),as.double(l), as.double(c),as.double(zr),as.double(hs), as.double(mu),as.integer(ltyp),as.integer(r),as.integer(q), ans=double(length=1), PACKAGE="spc")$ans } names(arl) <- NULL return (arl) } spc/R/xDshewhartrunsrules.arl.R0000644000175100001440000000103411171640520016255 0ustar hornikusers xDshewhartrunsrules.arl <- function(delta, c=1, m=NULL, type="12") { eps <- 1e-6 if ( is.null(m) ) { m <- 4 arl1 <- xDshewhartrunsrulesFixedm.arl(delta, c=c, m=m, type=type) arl2 <- arl1 + 2*eps while ( abs(arl2-arl1)>eps & m<1e4 ) { m <- round(1.5 * m) arl1 <- xDshewhartrunsrulesFixedm.arl(delta, c=c, m=m, type=type) arl2 <- xDshewhartrunsrulesFixedm.arl(delta, c=c, m=m+1, type=type) } arl <- arl1 } else { arl <- xDshewhartrunsrulesFixedm.arl(delta, c=c, m=m, type=type) } arl }spc/R/xewma.arl.prerun.R0000644000175100001440000000346712050434426014623 0ustar hornikusers# Computation of EWMA ARLs (mean monitoring) under specified pr-run scenarios xewma.arl.prerun <- function(l, c, mu, zr=0, hs=0, sided="two", limits="fix", q=1, size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10) { if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( c<=0 ) warning("usually, c has to be positive") if ( zr>c & sided=="one" ) stop("wrong reflexion border") if ( (sided=="two" & abs(hs)>c) | (sided=="one" & (hsc)) ) warning("unusual headstart") ctyp <- pmatch(sided, c("one", "two")) - 1 if (is.na(ctyp)) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat")) if (is.na(ltyp)) stop("invalid limits type") if ( (sided=="one") & !(limits %in% c("fix", "vacl", "stat", "limit", "fixW")) ) stop("not supported for one-sided EWMA (not reasonable or not implemented yet") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") if ( size<2 ) stop("pre run size too small") if ( is.null(df) ) df = size - 1 if ( df<1 ) stop("degrees of freedom (df) too small") emode <- -1 + pmatch(estimated, c("mu", "sigma", "both")) if (is.na(emode)) stop("invalid to be estimated type") if ( qm.mu<4 ) stop("qm.mu is too small") if ( qm.sigma<4 ) stop("qm.sigma is too small") if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") arl <- .C("xewma_arl_prerun", as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.double(hs), as.double(mu), as.integer(ltyp), as.integer(q), as.integer(size), as.integer(df), as.integer(emode), as.integer(qm.mu), as.integer(qm.sigma), as.double(truncate), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- "arl" return (arl) } spc/R/xtewma.sf.R0000644000175100001440000000275212343300460013316 0ustar hornikusers# Computation of EWMA survival function (mean monitoring) xtewma.sf <- function(l, c, df, mu, n, zr=0, hs=0, sided="two", limits="fix", mode="tan", q=1, r=40) { if ( l<=0 || l>1 ) warning("l is typically between 0 and 1 -- you should really know what you do") if ( c <= 0 ) warning("usually, c has to be positive") if ( df < 1 ) stop("df must be greater or equal to 1") if ( n < 1 ) stop("n has to be a natural number") if ( zr > c & sided == "one") stop("wrong reflexion border") if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) ) warning("unusual headstart") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl")) if (is.na(ltyp)) stop("invalid limits type") ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan")) if ( is.na(ntyp) ) stop("substitution type not provided (yet)") if ( r < 4 ) stop("r is too small") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") sf <- .C("xtewma_sf", as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.double(hs), as.integer(df), as.double(mu), as.integer(ltyp), as.integer(r), as.integer(ntyp), as.integer(q), as.integer(n), ans=double(length=n),PACKAGE="spc")$ans names(sf) <- NULL sf } spc/R/phat.ewma.crit.R0000644000175100001440000000221412505744156014235 0ustar hornikusers# Computation of EWMA phat upper control limits phat.ewma.crit <- function(lambda, L0, mu, n, z0, sigma=1, type="known", LSL=-3, USL=3, N=15, qm=25) { if ( lambda <= 0 || lambda > 1 ) stop("lambda has to be between 0 and 1") p.star <- pnorm( LSL/sigma ) + pnorm( -USL/sigma ) if ( type == "estimated" ) p.star <- 0 if ( L0 < 1 ) stop("L0 is too small") if ( n < 1 ) stop("n must be >= 1") if ( z0 < p.star & z0 >= 1 ) stop("wrong headstart") if ( sigma<1e-10 ) stop("sigma much too small") ctyp <- -1 + pmatch(type, c("known", "estimated")) if ( is.na(ctyp) ) stop("invalid sigma mode") if ( LSL >= USL ) stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)") if ( N < 3 ) stop("N too small") if ( qm < 5 ) stop("qm too small") ucl <- .C("ewma_phat_crit_coll", as.double(lambda), as.double(L0), as.double(mu), as.double(sigma), as.integer(n), as.double(z0), as.integer(ctyp), as.double(LSL), as.double(USL), as.integer(N), as.integer(qm), ans=double(length=1), PACKAGE="spc")$ans names(ucl) <- "ucl" ucl }spc/R/xcusum.ad.R0000644000175100001440000000134410061356232013310 0ustar hornikusers# Computation of CUSUM steady-state ARLs (mean monitoring) xcusum.ad <- function(k, h, mu1, mu0 = 0, sided = "one", r = 30) { if (k<0) stop("k has to be non-negative") if (h<=0) stop("h has to be positive") if (r<4) stop("r is too small") if (r>30 & r<=50 & sided=="two") warning("computation needs some time") if (r>50 & sided=="two") warning("ought to be restricted to very fast CPUs") ctyp <- pmatch(sided, c("one", "two", "Crosier")) - 1 if (is.na(ctyp)) stop("invalid cusum type") ad <- .C("xcusum_ad",as.integer(ctyp),as.double(k), as.double(h),as.double(mu0),as.double(mu1),as.integer(r), ans=double(length=1),PACKAGE="spc")$ans names(ad) <- "ad" return(ad) } spc/R/xshewhartrunsrules.crit.R0000644000175100001440000000110611171635330016337 0ustar hornikusers xshewhartrunsrules.crit <- function(L0, mu=0, type="12") { if (type=="14" & L0>255) { stop("L0 too large for type=\"14\"") } else { c1 <- 1 c2 <- 1.5 arl1 <- xshewhartrunsrules.arl(mu,c=c1,type=type) arl2 <- xshewhartrunsrules.arl(mu,c=c2,type=type) a.error <- 1; c.error <- 1 while ( a.error>1e-6 && c.error>1e-8 ) { c3 <- c1 + (L0-arl1)/(arl2-arl1)*(c2-c1) arl3 <- xshewhartrunsrules.arl(mu,c=c3,type=type) c1 <- c2; c2 <- c3 arl1 <- arl2; arl2 <- arl3 a.error <- abs(arl2-L0); c.error <- abs(c2-c1) } } c3 }spc/R/xsewma.crit.R0000644000175100001440000000315412105000422013632 0ustar hornikusers# Computation of EWMA critical values for given ARL # (simultaneous mean and variance monitoring) xsewma.crit <- function(lx, ls, L0, df, mu0=0, sigma0=1, cu=NULL, hsx=0, hss=1, s2.on=TRUE, sided="upper", mode="fixed", Nx=30, Ns=40, qm=30) { if (lx<=0 || lx>1) stop("lx has to be between 0 and 1") if (ls<=0 || ls>1) stop("ls has to be between 0 and 1") if (L0<1) stop("L0 is too small") if (sigma0<=0) stop("sigma0 must be positive") if (mode=="fixed" & sided=="two") { if (is.null(cu)) stop("set cu") if (cucu) stop("hs must be smaller than cu") cu0 <- cu } else { cu0 <- 0 } if (df<1) stop("df must be positive") s_squared <- as.numeric(s2.on) if ( !(s_squared %in% c(0,1)) ) stop("wrong value for s2.on") ctyp <- pmatch(sided, c("upper","Rupper","two","lower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") ltyp <- pmatch(mode, c("fixed","unbiased")) - 1 if (is.na(ltyp)) stop("invalid limits type") if (Nx<5) stop("r.x is too small") if (Ns<10) stop("r.s is too small") if (qm<10) stop("qm is too small") c <- .C("xsewma_crit",as.integer(ctyp),as.integer(ltyp), as.double(lx),as.double(ls), as.double(L0),as.double(cu0),as.double(hsx),as.double(hss), as.double(mu0),as.double(sigma0), as.integer(df),as.integer(Nx),as.integer(Ns), as.integer(qm), ans=double(length=3),PACKAGE="spc")$ans names(c) <- c("cx","cl","cu") return (c) } spc/R/xewma.sf.prerun.R0000644000175100001440000000441012371130756014447 0ustar hornikusers# Computation of EWMA survival function (mean monitoring) under specified pre-run scenarios xewma.sf.prerun <- function(l, c, mu, n, zr=0, hs=0, sided="one", limits="fix", q=1, size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE, bound=1e-10) { if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1") if ( c <= 0 ) warning("usually, c has to be positive") if ( n < 1 ) stop("n has to be a natural number") if ( zr > c & sided == "one") stop("wrong reflexion border") if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) ) stop("wrong headstart") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat")) if (is.na(ltyp)) stop("invalid limits type") if ( (sided=="one") & !( limits %in% c("fix", "vacl", "stat") ) ) stop("not supported for one-sided EWMA (not reasonable or not implemented yet") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") if ( size<2 ) stop("pre run size too small") if ( is.null(df) ) df = size - 1 if ( df<1 ) stop("degrees of freedom (df) too small") emode <- -1 + pmatch(estimated, c("mu", "sigma", "both")) if (is.na(emode)) stop("invalid to be estimated type") if ( qm.mu<4 ) stop("qm.mu is too small") if ( qm.sigma<4 ) stop("qm.sigma is too small") if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") if ( bound < 0 | bound >= 0.001 ) stop("wrong value for bound (should follow 0 < truncate < 0.001)") sf <- .C("xewma_sf_prerun", as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.double(hs), as.double(mu), as.integer(ltyp), as.integer(q), as.integer(n), as.integer(size), as.integer(df), as.integer(emode), as.integer(qm.mu), as.integer(qm.sigma), as.double(truncate), as.integer(tail_approx), as.double(bound), ans=double(length=n),PACKAGE="spc")$ans names(sf) <- NULL sf }spc/R/xewma.q.prerun.R0000644000175100001440000000437412371127771014313 0ustar hornikusers# Computation of EWMA quantiles (mean monitoring) under specified pr-run scenarios xewma.q.prerun <- function(l, c, mu, p, zr=0, hs=0, sided="two", limits="fix", q=1, size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, bound=1e-10) { if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1") if ( c<=0 ) warning("usually, c has to be positive") if ( p <= 0 | p >= 1) stop("quantile level p must be in (0,1)") if ( zr > c & sided == "one") stop("wrong reflexion border") if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) ) stop("wrong headstart") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat")) if (is.na(ltyp)) stop("invalid limits type") if ( (sided=="one") & !( limits %in% c("fix", "vacl", "stat") ) ) stop("not supported for one-sided EWMA (not reasonable or not implemented yet") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") if ( size<2 ) stop("pre run size too small") if ( is.null(df) ) df = size - 1 if ( df<1 ) stop("degrees of freedom (df) too small") emode <- -1 + pmatch(estimated, c("mu", "sigma", "both")) if (is.na(emode)) stop("invalid to be estimated type") if ( qm.mu<4 ) stop("qm.mu is too small") if ( qm.sigma<4 ) stop("qm.sigma is too small") if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") if ( bound < 0 | bound >= 0.001 ) stop("wrong value for bound (should follow 0 < truncate < 0.001)") quant <- .C("xewma_q_prerun", as.integer(ctyp), as.double(l), as.double(c), as.double(p), as.double(zr), as.double(hs), as.double(mu), as.integer(ltyp), as.integer(q), as.integer(size), as.integer(df), as.integer(emode), as.integer(qm.mu), as.integer(qm.sigma), as.double(truncate), as.double(bound), ans=double(length=1),PACKAGE="spc")$ans names(quant) <- "q" quant } spc/R/xtewma.ad.R0000644000175100001440000000241612343336601013275 0ustar hornikusers# Computation of EWMA steady-state ARLs (mean monitoring, t distributed data) xtewma.ad <- function(l, c, df, mu1, mu0=0, zr=0, z0=0, sided="one", limits="fix", steady.state.mode="conditional", mode="tan", r=40) { if ( l<=0 || l>1 ) warning("l has to be between 0 and 1") if ( c<=0 ) warning("usually, c has to be positive") if ( zr>c & sided=="one" ) stop("wrong reflexion border") if ( r<4 ) stop("r is too small") ctyp <- pmatch(sided, c("one", "two")) - 1 if (is.na(ctyp)) stop("invalid ewma type") ltyp <- pmatch(limits, c("fix","vacl")) - 1 if ( is.na(ltyp) ) stop("invalid limits type") styp <- pmatch(steady.state.mode, c("conditional", "cyclical")) - 1 if (is.na(styp)) stop("invalid steady.state.mode") if ( abs(z0) > abs(c) ) stop("wrong restarting value") ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan")) if ( is.na(ntyp) ) stop("substitution type not provided (yet)") ad <- .C("xtewma_ad", as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.integer(df), as.double(mu0), as.double(mu1), as.double(z0), as.integer(ltyp), as.integer(styp), as.integer(r), as.integer(ntyp), ans=double(length=1), PACKAGE="spc")$ans names(ad) <- "ad" return (ad) } spc/R/xsewma.q.crit.R0000644000175100001440000000320612052660443014107 0ustar hornikusers# Computation of EWMA critical values for given QRL # (simultaneous mean and variance monitoring) xsewma.q.crit <- function(lx, ls, L0, alpha, df, mu0=0, sigma0=1, csu=NULL, hsx=0, hss=1, sided="upper", mode="fixed", Nx=20, Ns=40, qm=30, c.error=1e-12, a.error=1e-9) { if (lx<=0 || lx>1) stop("lx has to be between 0 and 1") if (ls<=0 || ls>1) stop("ls has to be between 0 and 1") if (L0<1) stop("L0 is too small") if ( alpha<=0 | alpha>=1 ) stop("quantile level alpha must be in (0,1)") if ( df<1 ) stop("df must be positive") if ( sigma0<=0 ) stop("sigma0 must be positive") if ( mode=="fixed" & sided=="two" ) { if ( is.null(csu) ) stop("set csu") if ( csucsu ) stop("hs must be smaller than csu") cu0 <- csu } else { cu0 <- 0 } ctyp <- pmatch(sided, c("upper","two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- pmatch(mode, c("fixed","unbiased")) - 1 if ( is.na(ltyp) ) stop("invalid limits type") if ( Nx<5 ) stop("Nx is too small") if ( Ns<10 ) stop("Ns is too small") if ( qm<10 ) stop("qm is too small") c <- .C("xsewma_q_crit", as.integer(ctyp), as.integer(ltyp), as.double(lx), as.double(ls), as.double(L0), as.double(alpha), as.double(cu0), as.double(hsx), as.double(hss), as.double(mu0), as.double(sigma0), as.integer(df), as.integer(Nx), as.integer(Ns), as.integer(qm), as.double(c.error), as.double(a.error), ans=double(length=3),PACKAGE="spc")$ans names(c) <- c("cx", "csl","csu") return (c) } spc/R/xewma.q.crit.prerun.R0000644000175100001440000000574112371130335015240 0ustar hornikusersxewma.q.crit.prerun <- function(l, L0, mu, p, zr=0, hs=0, sided="two", limits="fix", size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, bound=1e-10, c.error=1e-10, p.error=1e-9, OUTPUT=FALSE) { if ( OUTPUT ) cat("\nc\t\tp\n") c2 <- xewma.q.crit(l, L0, mu, p, zr=zr, hs=hs, sided=sided, limits=limits, OUTPUT=FALSE) p2 <- 1 - xewma.sf.prerun(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) if ( p2 > p ) { while ( p2 > p ) { p1 <- p2 c2 <- c2 + .5 p2 <- 1 - xewma.sf.prerun(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } c1 <- c2 - .5 } else { while ( p2 <= p ) { p1 <- p2 c2 <- c2 - .5 p2 <- 1 - xewma.sf.prerun(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } c1 <- c2 + .5 } if ( size < 41 ) { if ( qm.mu < 70 ) qm.mu <- 70 if ( qm.mu < 70 ) qm.mu <- 70 if ( size < 21 ) { if ( qm.mu < 90 ) qm.mu <- 90 if ( qm.mu < 90 ) qm.mu <- 90 } if ( p2 > p ) { while ( p2 > p ) { p1 <- p2 c2 <- c2 + .1 p2 <- 1 - xewma.sf.prerun(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } c1 <- c2 - .1 } else { while ( p2 <= p ) { p1 <- p2 c2 <- c2 - .1 p2 <- 1 - xewma.sf.prerun(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } c1 <- c2 + .1 } } p.error_ <- 1; c.error_ <- 1 while ( p.error_ > p.error & c.error_ > c.error ) { c3 <- c1 + (p - p1)/(p2 - p1)*(c2 - c1) p3 <- 1 - xewma.sf.prerun(l, c3, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0] if ( OUTPUT ) cat(paste(c3,"\t",p3,"\n")) c1 <- c2; c2 <- c3 p1 <- p2; p2 <- p3 p.error_ <- abs(p2 - p); c.error_ <- abs(c2 - c1) } names(c3) <- "c" c3 } spc/R/xDewma.arl.R0000644000175100001440000000246611214125502013404 0ustar hornikusers# Computation of EWMA ARLs (drift monitoring) xDewma.arl <- function(l, c, delta, zr=0, hs=0, sided="one", limits="fix", mode="Gan", m=NULL, q=1, r=40, with0=FALSE) { if (l<=0 || l>1) stop("l has to be between 0 and 1") if (c<=0) stop("c has to be positive") if (zr>c & sided=="one") stop("wrong reflexion border") if ( (sided=="two" & abs(hs)>c) | (sided=="one" & (hsc)) ) stop("wrong headstart") if (r<4) stop("r is too small") ctyp <- pmatch(sided, c("one", "two")) - 1 if (is.na(ctyp)) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix","vacl","fir","both","Steiner","Knoth","fink","fixW","fixC")) if (is.na(ltyp)) stop("invalid limits type") cmode <- pmatch(mode, c("Gan", "Knoth", "Waldmann")) - 1 if (is.na(cmode)) stop("invalid algorithm mode") if ( is.null(m) ) { m <- 0 } else { if ( m<1 ) stop("m is too small") } q <- round(q) if (q<1) stop("wrong change point position (q)") arl <- .C("xDewma_arl",as.integer(ctyp),as.double(l), as.double(c),as.double(zr),as.double(hs), as.double(delta),as.integer(ltyp),as.integer(m),as.integer(r), as.integer(with0),as.integer(cmode),as.integer(q), ans=double(length=1),PACKAGE="spc")$ans names(arl) <- "arl" return (arl) } spc/R/mewma.crit.R0000644000175100001440000000111112272510156013442 0ustar hornikusers# Computation of MEWMA threshold (multivariate mean monitoring) mewma.crit <- function(l, L0, p, hs=0, r=20) { if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( L0<1 ) stop("L0 is too small") if ( p<1 ) stop("wrong dimension parameter") if ( hs<0 ) stop("wrong head start value") if ( r<4 ) stop("resolution too small") h <- .C("mewma_crit", as.double(l), as.double(L0), as.integer(p), as.double(hs), as.integer(r), ans=double(length=1), PACKAGE="spc")$ans names(h) <- NULL h }spc/R/xcusum.crit.L0h.R0000644000175100001440000000156011523303017014304 0ustar hornikusers # Computation of CUSUM k (reference value) for given in-control ARL and threshold h (mean monitoring) xcusum.crit.L0h <- function(L0, h, hs=0, sided="one", r=30, L0.eps=1e-6, k.eps=1e-8) { h.max <- xcusum.crit(0, L0, 0) if ( h.max < h ) stop("h too large or L0 far too small") k1 <- 0 L0_1 <- 0 while ( L0_1 < L0 ) { k1 <- k1 + .1 L0_1 <- xcusum.arl(k1, h, 0, hs=hs, sided=sided, r=r) } while ( L0_1 > L0 & k1 > 0.01) { k1 <- k1 - .01 L0_1 <- xcusum.arl(k1, h, 0, hs=hs, sided=sided, r=r) } k2 <- k1 + .01 L0_2 <- xcusum.arl(k2, h, 0, hs=hs, r=r) dk <- 1 while ( abs(L0-L0_2) > L0.eps & abs(dk) > k.eps ) { k3 <- k1 + ( L0 - L0_1 ) / ( L0_2 - L0_1 ) * ( k2 - k1 ) L0_3 <- xcusum.arl(k3, h, 0, hs=hs, sided=sided, r=r) # secant rule dk <- k3-k2 k1 <- k2 L0_1 <- L0_2 k2 <- k3 L0_2 <- L0_3 } k3 } spc/R/sewma.crit.prerun.R0000644000175100001440000000413612053710071014767 0ustar hornikusers# Computation of EWMA critical values for given ARL (variance monitoring) with pre-run uncertainty sewma.crit.prerun <- function(l, L0, df1, df2, sigma0=1, cl=NULL, cu=NULL, hs=1, sided="upper", mode="fixed", r=40, qm=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE, c.error=1e-10, a.error=1e-9) { cu0 <- cl0 <- 0 if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( L0<1 ) stop("L0 is too small") if ( df1<1 ) stop("df1 must be positive") if ( df2<1 ) stop("df2 must be positive") if ( sigma0<=0 ) stop("sigma0 must be positive") if ( sided=="Rupper" ) { if ( is.null(cl) ) stop("set cl") if ( cl<=0 ) stop("cl must be positive") cl0 <- cl if ( hs= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") c <- .C("sewma_crit_prerun", as.integer(ctyp), as.integer(ltyp), as.double(l), as.integer(L0), as.double(cl0), as.double(cu0), as.double(hs), as.double(sigma0), as.integer(df1), as.integer(r), as.integer(qm), as.integer(df2), as.integer(qm.sigma), as.double(truncate), as.integer(tail_approx), as.double(c.error), as.double(a.error), ans=double(length=2),PACKAGE="spc")$ans names(c) <- c("cl", "cu") return (c) } spc/R/sewma.q.R0000644000175100001440000000214412052452130012747 0ustar hornikusers# Computation of EWMA quantiles (variance monitoring) sewma.q <- function(l, cl, cu, sigma, df, alpha, hs=1, sided="upper", r=40, qm=30) { if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1") if ( cu<=0 ) stop("cu has to be positive") if ( cl<0 ) stop("cl has to be non-negative") if ( sided!="upper" & cl<1e-6 ) stop("cl is too small") if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)") if ( hscu ) stop("wrong headstart hs") ctyp <- pmatch(sided, c("upper","Rupper","two","Rlower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") if ( r<10 ) stop("r is too small") if ( qm<5 ) stop("qm is too small") quant <- .C("sewma_q", as.integer(ctyp), as.double(l), as.double(cl), as.double(cu), as.double(alpha), as.double(hs), as.integer(r), as.double(sigma), as.integer(df), as.integer(qm), ans=double(length=1),PACKAGE="spc")$ans names(quant) <- "q" quant } spc/R/xs.res.ewma.arl.R0000644000175100001440000000236511532430161014332 0ustar hornikusers# Computation of res-EWMA ARLs (simultaneous mean & variance monitoring) xs.res.ewma.arl <- function(lx, cx, ls, csu, mu, sigma, alpha=0, n=5, hsx=0, rx=40, hss=1, rs=40, qm=30) { if ( lx<=0 || lx>1 ) stop("lx has to be between 0 and 1") if ( ls<=0 || ls>1 ) stop("ls has to be between 0 and 1") if ( cx <= 0 ) stop("cx has to be positive") if ( csu <= 0 ) stop("csu has to be positive") if ( sigma <= 0 ) stop("sigma must be positive") if ( abs(alpha)>1 ) warning("nonstationary AR(1) process") if ( n < 2 ) warning("n is too small") n <- round(n) if ( abs(hsx) > cx ) stop("wrong headstart hsx") if ( hss < 0 | hss > csu ) stop("wrong headstart hss") if ( rx < 5 ) stop("rx is too small") if ( rs < 10 ) stop("rs is too small") if ( qm < 5 ) stop("qm is too small") ctyp <- 1 # later more arl <- .C("xsewma_res_arl",as.double(alpha),as.integer(n-1),as.integer(ctyp), as.double(lx),as.double(cx),as.double(hsx),as.integer(rx), as.double(ls),as.double(csu),as.double(hss),as.integer(rs), as.double(mu),as.double(sigma),as.integer(qm), ans=double(length=1),PACKAGE="spc")$ans names(arl) <- "arl" return (arl) } spc/R/xewma.q.crit.R0000644000175100001440000000200712132006423013711 0ustar hornikusersxewma.q.crit <- function(l, L0, mu, alpha, zr=0, hs=0, sided="two", limits="fix", r=40, c.error=1e-12, a.error=1e-9, OUTPUT=FALSE) { c2 <- 0 p2 <- 1 if ( OUTPUT ) cat("\nc\t\tp\n") while ( p2 > alpha ) { p1 <- p2 c2 <- c2 + .5 p2 <- 1 - xewma.sf(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } while ( p2 <= alpha & c2 > .02 ) { p1 <- p2 c2 <- c2 - .02 p2 <- 1 - xewma.sf(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } c1 <- c2 + .02 a.error_ <- 1; c.error_ <- 1 while ( a.error_ > a.error & c.error_ > c.error ) { c3 <- c1 + (alpha - p1)/(p2 - p1)*(c2 - c1) p3 <- 1 - xewma.sf(l, c3, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0] if ( OUTPUT ) cat(paste(c3,"\t",p3,"\n")) c1 <- c2; c2 <- c3 p1 <- p2; p2 <- p3 a.error_ <- abs(p2 - alpha); c.error_ <- abs(c2 - c1) } names(c3) <- "c" c3 } spc/R/xtewma.arl.R0000644000175100001440000000315312343300332013456 0ustar hornikusers# Computation of EWMA ARLs (mean monitoring, t distributed data) xtewma.arl <- function(l, c, df, mu, zr=0, hs=0, sided="two", limits="fix", mode="tan", q=1, r=40) { if ( l<=0 || l>1 ) warning("l is typically between 0 and 1 -- you should really know what you do") if ( c<=0 ) warning("usually, c has to be positive") if ( df < 1 ) stop("df must be greater or equal to 1") if ( zr>c & sided=="one" ) stop("wrong reflexion border") if ( (sided=="two" & abs(hs)>c) | (sided=="one" & (hsc)) ) warning("unusual headstart") if ( r<4 ) stop("r is too small") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl")) if ( is.na(ltyp) ) stop("invalid limits type") ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan")) if ( is.na(ntyp) ) stop("substitution type not provided (yet)") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") if ( limits=="fix" & q>1 ) { arl <- .C("xtewma_arl",as.integer(ctyp),as.double(l), as.double(c),as.double(zr),as.double(hs),as.integer(df), as.double(mu),as.integer(ltyp),as.integer(r),as.integer(ntyp),as.integer(q), ans=double(length=q), PACKAGE="spc")$ans } else { arl <- .C("xtewma_arl",as.integer(ctyp),as.double(l), as.double(c),as.double(zr),as.double(hs),as.integer(df), as.double(mu),as.integer(ltyp),as.integer(r),as.integer(ntyp),as.integer(q), ans=double(length=1), PACKAGE="spc")$ans } names(arl) <- NULL return (arl) } spc/R/xcusum.crit.L0L1.R0000644000175100001440000000222211523310765014335 0ustar hornikusers # Computation of CUSUM k (reference value) and threshold h for given in-control ARL L0 and out-of-control ARL L1 (mean monitoring) # Ewan & Kemp 1960 or Kemp 1962 xcusum.crit.L0L1 <- function(L0, L1, hs = 0, sided="one", r = 30, L1.eps=1e-6, k.eps=1e-8) { k1 <- 0 L1_1 <- L1 + 1 while ( L1_1 > L1 ) { k1 <- k1 + .1 h1 <- xcusum.crit(k1, L0, hs=hs, sided=sided, r=r) L1_1 <- xcusum.arl(k1, h1, 2*k1, hs=hs, sided=sided, r=r) } while ( L1_1 < L1 & k1 > 0.01 ) { k1 <- k1 - .01 h1 <- xcusum.crit(k1, L0, hs=hs, sided=sided, r=r) L1_1 <- xcusum.arl(k1, h1, 2*k1, hs=hs, sided=sided, r=r) } k2 <- k1 + .01 h2 <- xcusum.crit(k2, L0, hs=hs, sided=sided, r=r) L1_2 <- xcusum.arl(k2, h2, 2*k2, hs=hs, sided=sided, r=r) dk <- 1 while ( abs(L1-L1_2) > L1.eps & abs(dk) > k.eps ) { k3 <- k1 + ( L1 - L1_1 ) / ( L1_2 - L1_1 ) * ( k2 - k1 ) h3 <- xcusum.crit(k3, L0, hs=hs, sided=sided, r=r) L1_3 <- xcusum.arl(k3, h3, 2*k3, hs=hs, sided=sided, r=r) # secant rule dk <- k3-k2 k1 <- k2 L1_1 <- L1_2 k2 <- k3 L1_2 <- L1_3 } result <- c(k3, h3) names(result) <- c("k", "h") result } spc/R/sewma.arl.R0000644000175100001440000000231412210715552013272 0ustar hornikusers# Computation of EWMA ARLs (variance monitoring) sewma.arl <- function(l, cl, cu, sigma, df, s2.on=TRUE, hs=NULL, sided="upper", r=40, qm=30) { mitte <- sqrt( 2/df ) * gamma( (df+1)/2 )/ gamma( df/2 ) if ( is.null(hs) ) { if ( s2.on ) { hs <- 1 } else { hs <- mitte } } if ( l<=0 || l>1 ) stop("l has to be between 0 and 1") if ( cu<=0 ) stop("cu has to be positive") if ( cl<0 ) stop("cl has to be non-negative") if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") s_squared <- as.numeric(s2.on) if ( !(s_squared %in% c(0,1)) ) stop("wrong value for s2.on") if ( hscu ) stop("wrong headstart") ctyp <- pmatch(sided, c("upper", "Rupper", "two", "Rlower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") if (r<10) stop("r is too small") if (qm<10) stop("qm is too small") arl <- .C("sewma_arl",as.integer(ctyp),as.double(l), as.double(cl),as.double(cu),as.double(hs), as.double(sigma),as.integer(df),as.integer(r),as.integer(qm), as.integer(s_squared), ans=double(length=1),PACKAGE="spc")$ans names(arl) <- "arl" return (arl) } spc/R/mewma.arl.f.R0000644000175100001440000001753512615437477013543 0ustar hornikusers# Computation of MEWMA ARLs (multivariate mean monitoring), returns function mewma.arl.f <- function(l, cE, p, delta=0, r=20, ntype=NULL, qm0=20, qm1=qm0) { if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( cE<=0 ) stop("threshold c has to be positive") if ( p<1 ) stop("wrong dimension parameter") if ( delta<0 ) stop("wrong magnitude value") if ( r<4 ) stop("resolution too small") if ( qm0<5 ) stop("more quadrature nodes needed") if ( qm1<5 ) stop("more quadrature nodes needed") if ( is.null(ntype) ) { if ( delta <1e-10 ) { ntype <- "gl2" } else { #if ( p %in% c(2,4) ) { if ( p==2 ) { ntype <- "gl3" } else { ntype <- "gl5" } } } # collocation basis of Chebshev polynomials Tn <- Vectorize(function(z, n) { if ( n==0 ) result <- 1 if ( n==1 ) result <- z if ( n==2 ) result <- 2*z^2 - 1 if ( n==3 ) result <- 4*z^3 - 3*z if ( n==4 ) result <- 8*z^4 - 8*z^2 + 1 if ( n==5 ) result <- 16*z^5 - 20*z^3 + 5*z if ( n>5 ) result <- cos( n*acos(z) ) result }) qtyp <- pmatch(tolower(ntype), c("gl", "co", "ra", "cc", "mc", "sr", "co2", "gl2", "gl3", "gl4", "gl5", "co3", "co4")) - 1 if ( is.na(qtyp) ) stop("invalid type of numerical algorithm") if ( abs(delta) < 1e-10 ) { # in-control LENGTH <- 3*r zeug <- .C("mewma_arl_f", as.double(l), as.double(cE), as.integer(p), as.double(delta), as.integer(r), as.integer(qtyp), as.integer(qm0), as.integer(qm1), ans=double(length=LENGTH), PACKAGE="spc")$ans g <- zeug[1:r] w <- zeug[1:r + r] z <- zeug[1:r + 2*r] # helper functions cE <- cE * l/(2-l) l2 <- ( (1-l)/l )^2 fchi <- function(a, u) dchisq( u/l^2, p, ncp=l2*a ) / l^2 FCHI <- function(a, u) pchisq( u/l^2, p, ncp=l2*a ) if ( qtyp %in% c(0,2,5) ) arl <- Vectorize(function(a) 1 + sum( w * fchi(a, z) * g ), "a") # ordinary GL or Radau or Simpson rule Nystroem if ( qtyp==7 ) arl <- Vectorize(function(a) 1 + sum( w * fchi(a, z^2) * g * 2*z ), "a") # GL Nystroem with ()^2 substitution if ( qtyp==1 ) arl <- Vectorize(function(a) sum( Tn( (2*a-cE)/cE, 0:(r-1) ) * g ), "a") # collocation if ( qtyp==3 ) arl <- Vectorize(function(a) 1 + sum( w * fchi(a, z^2) * g ) * cE/2 , "a") # Clenshaw-Curtis if ( qtyp==4 ) arl <- Vectorize(function(a) 1 + sum( ( FCHI(a, z^2) - FCHI(a, c(0, z[-length(z)]^2)) ) * g), "a") # Markov chain (Runger/Prabhu) } else { # out-of-control if ( qtyp==4 ) { cE_ <- sqrt( cE * l/(2-l) ) w <- 2*cE_/( 2*r + 1 ) ii <- function(ix, iy) (ix-r)^2 + iy^2 < cE_^2/w^2 CIRC <- as.vector( t(outer( 0:(2*r), 0:r, ii)) ) dQ <- sum(CIRC) LENGTH <- dQ } else { r2 <- r^2 LENGTH <- r2 + 4*r } zeug <- .C("mewma_arl_f", as.double(l), as.double(cE), as.integer(p), as.double(delta), as.integer(r), as.integer(qtyp), as.integer(qm0), as.integer(qm1), ans=double(length=LENGTH), PACKAGE="spc")$ans if ( qtyp!=4 ) { g <- zeug[1:r2] w0 <- zeug[1:r + r2] z0 <- zeug[1:r + r2 + r] w1 <- zeug[1:r + r2 + 2*r] z1 <- zeug[1:r + r2 + 3*r] } else { g <- zeug[1:dQ] } # helpers l2 <- ( (1-l)/l )^2 h <- cE * l/(2-l) rdc <- l * sqrt( delta/h ) sig <- l / sqrt( h ) if ( qtyp %in% c(0, 2, 3, 5) ) arl <- Vectorize(function(a, b) { # ordinary GL or Radau or CC or Simpson rule Nystroem if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta ) b_ <- b / sqrt( delta * h ) m <- rdc + (1-l)*b_ eta <- l2 * h * (1-b_^2) * a_ if ( eta < 1e-10 ) eta <- 0 result <- 1 for ( i in 1:r ) { korr <- h * (1-z1[i]^2) / l^2 outer <- korr * w1[i] * dnorm( z1[i], mean=m, sd=sig) inner <- sum( w0 * dchisq( korr*z0, p-1, eta) * g[ (i-1)*r + 1:r ] ) result <- result + inner * outer } result }) if ( qtyp==7 ) arl <- Vectorize(function(a, b) { # GL Nystroem with ()^2 substitution if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta ) b_ <- b / sqrt( delta * h ) m <- rdc + (1-l)*b_ eta <- l2 * h * (1-b_^2) * a_ if ( eta < 1e-10 ) eta <- 0 result <- 1 for ( i in 1:r ) { korr <- h * (1-z1[i]^2) / l^2 outer <- korr * w1[i] * dnorm( z1[i], mean=m, sd=sig) inner <- sum( w0 * dchisq( korr*z0^2, p-1, eta) * 2*z0 * g[ (i-1)*r + 1:r ] ) result <- result + inner * outer } result }) if ( qtyp==8 ) arl <- Vectorize(function(a, b) { # GL Nystroem with ()^2 plus sin() substitution if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta ) b_ <- b / sqrt( delta * h ) m <- rdc + (1-l)*b_ eta <- l2 * h * (1-b_^2) * a_ if ( eta < 1e-10 ) eta <- 0 result <- 1 for ( i in 1:r ) { korr <- h * ( 1 - sin(z1[i])^2 ) / l^2 outer <- korr * w1[i] * dnorm( sin(z1[i]), mean=m, sd=sig) * cos(z1[i]) inner <- sum( w0 * dchisq( korr*z0^2, p-1, eta) * 2*z0 * g[ (i-1)*r + 1:r ] ) result <- result + inner * outer } result }) if ( qtyp==9 ) arl <- Vectorize(function(a, b) { # GL Nystroem with ()^2 plus tan() substitution if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta ) b_ <- b / sqrt( delta * h ) m <- rdc + (1-l)*b_ eta <- l2 * h * (1-b_^2) * a_ if ( eta < 1e-10 ) eta <- 0 result <- 1 for ( i in 1:r ) { korr <- h * ( 1 - tan(z1[i])^2 ) / l^2 outer <- korr * w1[i] * dnorm( tan(z1[i]), mean=m, sd=sig) / cos(z1[i])^2 inner <- sum( w0 * dchisq( korr*z0^2, p-1, eta) * 2*z0 * g[ (i-1)*r + 1:r ] ) result <- result + inner * outer } result }) if ( qtyp==10 ) arl <- Vectorize(function(a, b) { # GL Nystroem with ()^2 plus sinh() substitution norm <- sinh(1) if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta ) b_ <- b / sqrt( delta * h ) m <- rdc + (1-l)*b_ eta <- l2 * h * (1-b_^2) * a_ if ( eta < 1e-10 ) eta <- 0 result <- 1 for ( i in 1:r ) { korr <- h * ( 1 - (sinh(z1[i])/norm)^2 ) / l^2 outer <- korr * w1[i] * dnorm( sinh(z1[i])/norm, mean=m, sd=sig) * cosh(z1[i])/norm inner <- sum( w0 * dchisq( korr*z0^2, p-1, eta) * 2*z0 * g[ (i-1)*r + 1:r ] ) result <- result + inner * outer } result }) if ( qtyp %in% c(1, 6, 11, 12) ) arl <- Vectorize(function(a, b) { # collocation if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta ) b_ <- b / sqrt( delta * h ) result <- 0 for ( i in 1:r ) { outer <- Tn( 2*a_-1, i-1 ) inner <- sum( Tn( b_, 0:(r-1)) * g[ (i-1)*r + 1:r ] ) result <- result + inner * outer } result }) if ( qtyp==4 ) arl <- Vectorize(function(a, b) { # Markov chain (Runger/Prabhu) #a <- sqrt(a) cE_ <- sqrt( cE * l/(2-l) ) w <- 2*cE_/( 2*r + 1 ) wl <- w^2 / l^2 ii <- function(ix, iy) (ix-r)^2 + iy^2 < cE_^2/w^2 Vf <- function(iy,jy) pchisq( (jy+.5)^2*wl, p-1, ncp=(iy*w)^2*l2) - as.numeric(jy>0)*pchisq( (jy-.5)^2*wl, p-1, ncp=(iy*w)^2*l2) Hf <- function(ix,jx) pnorm( (-cE_+(jx+1)*w-(1-l)*(-cE_+(ix+.5)*w) )/l, mean=delta) - pnorm( (-cE_+jx*w-(1-l)*(-cE_+(ix+.5)*w) )/l, mean=delta) CIRC <- as.vector( t(outer( 0:(2*r), 0:r, ii)) ) Vv <- Vf( a/w, 0:r ) Hv <- Hf( (b+cE_)/w-.5, 0:(2*r) ) dQ <- sum(CIRC) Qv <- as.vector( Vv %o% Hv ) Qv_ <- Qv[ CIRC ] result <- 1 + sum( Qv_ * g ) }) } arl } spc/R/xewma.crit.prerun.R0000644000175100001440000000506612050434410014774 0ustar hornikusersxewma.crit.prerun <- function(l, L0, mu, zr=0, hs=0, sided="two", limits="fix", size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, c.error=1e-12, L.error=1e-9, OUTPUT=FALSE) { if ( OUTPUT ) cat("\nc\t\tL\n") c2 <- xewma.crit(l, L0, mu0=mu, zr=zr, hs=hs, sided=sided, limits=limits) L2 <- xewma.arl.prerun(l, c2, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate) if ( OUTPUT ) cat(paste(c2,"\t",L2,"\n")) if ( L2 < L0 ) { while ( L2 < L0 ) { L1 <- L2 c2 <- c2 + .5 L2 <- xewma.arl.prerun(l, c2, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate) if ( OUTPUT ) cat(paste(c2,"\t",L2,"\n")) } c1 <- c2 - .5 } else { while ( L2 >= L0 ) { L1 <- L2 c2 <- c2 - .5 L2 <- xewma.arl.prerun(l, c2, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate) if ( OUTPUT ) cat(paste(c2,"\t",L2,"\n")) } c1 <- c2 + .5 } if ( size < 51 ) { if ( qm.mu < 70 ) qm.mu <- 70 if ( qm.mu < 70 ) qm.mu <- 70 if ( size < 31 ) { if ( qm.mu < 90 ) qm.mu <- 90 if ( qm.mu < 90 ) qm.mu <- 90 } if ( L2 < L0 ) { while ( L2 < L0 ) { L1 <- L2 c2 <- c2 + .1 L2 <- xewma.arl.prerun(l, c2, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate) if ( OUTPUT ) cat(paste(c2,"\t",L2,"\n")) } c1 <- c2 - .1 } else { while ( L2 >= L0 ) { L1 <- L2 c2 <- c2 - .1 L2 <- xewma.arl.prerun(l, c2, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate) if ( OUTPUT ) cat(paste(c2,"\t",L2,"\n")) } c1 <- c2 + .1 } } L.error_ <- 1; c.error_ <- 1 while ( L.error_ > L.error & c.error_ > c.error ) { c3 <- c1 + (L0 - L1)/(L2 - L1)*(c2 - c1) L3 <- xewma.arl.prerun(l, c3, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate) if ( OUTPUT ) cat(paste(c3,"\t",L3,"\n")) c1 <- c2; c2 <- c3 L1 <- L2; L2 <- L3 L.error_ <- abs(L2 - L0); c.error_ <- abs(c2 - c1) } names(c3) <- "c" c3 } spc/R/quadrature.nodes.weights.R0000644000175100001440000000104112250406434016332 0ustar hornikusersquadrature.nodes.weights <- function(n, type="GL", x1=-1, x2=1) { if ( n < 1 ) stop("n has to be a natural number") qtyp <- pmatch(type, c("GL", "Ra")) - 1 if ( is.na(qtyp) ) stop("invalid quadrature type") if ( x1 >= x2 ) stop("x1 must be smaller than x2") nw <- .C("quadrature_nodes_weights", as.integer(n), as.double(x1), as.double(x2), as.integer(qtyp), ans=double(length=2*n), PACKAGE="spc")$ans qnw <- data.frame(nodes=nw[1:n], weights=nw[-(1:n)]) qnw }spc/R/xtcusum.arl.R0000644000175100001440000000165312553254253013701 0ustar hornikusers# Computation of CUSUM ARLs (mean monitoring, t distributed data) xtcusum.arl <- function(k, h, df, mu, hs=0, sided="one", mode="tan", r=30) { if ( k < 0 ) stop("k has to be non-negative") if ( h <= 0 ) stop("h has to be positive") if ( df < 1 ) stop("df must be greater or equal to 1") if ( hs < 0 | ( sided=="two" & hs>h/2+k ) | ( sided=="one" & hs>h ) ) stop("wrong headstart") ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan")) if ( is.na(ntyp) ) stop("substitution type not provided (yet)") if ( r < 4 ) stop("r is too small") ctyp <- pmatch(sided, c("one", "two")) - 1 if (is.na(ctyp)) stop("invalid cusum type") arl <- .C("xtcusum_arl", as.integer(ctyp), as.double(k), as.double(h), as.double(hs), as.integer(df), double(mu), as.integer(r), as.integer(ntyp), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- NULL return (arl) }spc/R/xtewma.q.crit.R0000644000175100001440000000204712343300353014104 0ustar hornikusersxtewma.q.crit <- function(l, L0, df, mu, alpha, zr=0, hs=0, sided="two", limits="fix", mode="tan", r=40, c.error=1e-12, a.error=1e-9, OUTPUT=FALSE) { c2 <- 0 p2 <- 1 if ( OUTPUT ) cat("\nc\t\tp\n") while ( p2 > alpha ) { p1 <- p2 c2 <- c2 + .5 p2 <- 1 - xtewma.sf(l, c2, df, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } while ( p2 <= alpha & c2 > .02 ) { p1 <- p2 c2 <- c2 - .02 p2 <- 1 - xtewma.sf(l, c2, df, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } c1 <- c2 + .02 a.error_ <- 1; c.error_ <- 1 while ( a.error_ > a.error & c.error_ > c.error ) { c3 <- c1 + (alpha - p1)/(p2 - p1)*(c2 - c1) p3 <- 1 - xtewma.sf(l, c3, df, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0] if ( OUTPUT ) cat(paste(c3,"\t",p3,"\n")) c1 <- c2; c2 <- c3 p1 <- p2; p2 <- p3 a.error_ <- abs(p2 - alpha); c.error_ <- abs(c2 - c1) } names(c3) <- "c" c3 } spc/R/xtewma.q.R0000644000175100001440000000304312343300465013145 0ustar hornikusers# Computation of EWMA quantiles (mean monitoring, t distributed data) xtewma.q <- function(l, c, df, mu, alpha, zr=0, hs=0, sided="two", limits="fix", mode="tan", q=1, r=40) { if ( l <= 0 | l > 1 ) warning("l is typically between 0 and 1 -- you should really know what you do") if ( c<=0 ) warning("usually, c has to be positive") if ( df < 1 ) stop("df must be greater or equal to 1") if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)") if ( zr > c & sided == "one") stop("wrong reflexion border") if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) ) warning("unusual headstart") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl")) if (is.na(ltyp)) stop("invalid limits type") ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan")) if ( is.na(ntyp) ) stop("substitution type not provided (yet)") if ( r < 4 ) stop("r is too small") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") quant <- .C("xtewma_q", as.integer(ctyp), as.double(l), as.double(c), as.double(alpha), as.double(zr), as.double(hs), as.integer(df), as.double(mu), as.integer(ltyp), as.integer(r), as.integer(ntyp), as.integer(q), ans=double(length=1),PACKAGE="spc")$ans names(quant) <- "q" quant } spc/R/xDshewhartrunsrulesFixedm.arl.R0000644000175100001440000000116411171637215017425 0ustar hornikusers xDshewhartrunsrulesFixedm.arl <- function(delta, c=1, m=100, type="12") { mus <- (1:m)*delta # Shewhart chart if (type=="1") { p0 <- pnorm( 3*c, mean=mus ) - pnorm( -3*c, mean=mus) arls <- 1/(1-p0[m]) for ( i in (m-1):1 ) arls <- 1 + p0[i]*arls } # ditto with runs rules if (type!="1") { Q <- xshewhartrunsrules.matrix(mus[m], c=c, type=type) dimQ <- nrow(Q) one <- rep(1, dimQ) I <- diag(1, dimQ) arls <- solve(I-Q, one) for ( i in (m-1):1 ) { Q <- xshewhartrunsrules.matrix(mus[i], c=c, type=type) arls <- 1 + (Q %*% arls)[,1] } } arl <- arls[1] arl }spc/R/mewma.arl.R0000644000175100001440000000243012534070702013263 0ustar hornikusers# Computation of MEWMA ARLs (multivariate mean monitoring) mewma.arl <- function(l, cE, p, delta=0, hs=0, r=20, ntype=NULL, qm0=20, qm1=qm0) { if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( cE<=0 ) stop("threshold c has to be positive") if ( p<1 ) stop("wrong dimension parameter") if ( delta<0 ) stop("wrong magnitude value") if ( hs<0 ) stop("wrong head start value") if ( r<4 ) stop("resolution too small") if ( qm0<5 ) stop("more quadrature nodes needed") if ( qm1<5 ) stop("more quadrature nodes needed") if ( is.null(ntype) ) { if ( delta <1e-10 ) { ntype <- "gl2" } else { #if ( p %in% c(2,4) ) { if ( p==2 ) { ntype <- "gl3" } else { ntype <- "gl5" } } } qtyp <- pmatch(tolower(ntype), c("gl", "co", "ra", "cc", "mc", "sr", "co2", "gl2", "gl3", "gl4", "gl5", "co3", "co4")) - 1 if ( is.na(qtyp) ) stop("invalid type of numerical algorithm") arl <- .C("mewma_arl", as.double(l), as.double(cE), as.integer(p), as.double(delta), as.double(hs), as.integer(r), as.integer(qtyp), as.integer(qm0), as.integer(qm1), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- NULL arl }spc/R/xsewma.sf.R0000644000175100001440000000265312050166071013320 0ustar hornikusers# Computation of EWMA survival function (simultaneous mean & variance monitoring) xsewma.sf <- function(n, lx, cx, ls, csu, df, mu, sigma, hsx=0, Nx=40, csl=0, hss=1, Ns=40, sided="upper", qm=30) { if ( n < 1 ) stop("n has to be a natural number") if ( lx<=0 | lx>1 ) stop("lx has to be between 0 and 1") if ( ls<=0 | ls>1 ) stop("ls has to be between 0 and 1") if ( cx<=0 ) stop("cx has to be positive") if ( csu<=0 ) stop("csu has to be positive") if ( csl<0 ) stop("csl has to be non-negative") if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") if ( abs(hsx)>cx ) stop("wrong headstart hsx") if ( hsscsu ) stop("wrong headstart hss") if ( Nx<5 ) stop("Nx is too small") if ( Ns<10 ) stop("Ns is too small") if ( qm<5 ) stop("qm is too small") ctyp <- pmatch(sided, c("upper","Rupper","two","lower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") sf <- .C("xsewma_sf", as.integer(ctyp), as.double(lx),as.double(cx),as.double(hsx),as.integer(Nx), as.double(ls),as.double(csl),as.double(csu),as.double(hss),as.integer(Ns), as.double(mu),as.double(sigma),as.integer(df),as.integer(qm), as.integer(n), ans=double(length=n),PACKAGE="spc")$ans names(sf) <- NULL sf } spc/R/xgrsr.crit.R0000644000175100001440000000120512205627572013514 0ustar hornikusers# Computation of GRSR (Girshick, Rubin, Shiryaev, Roberts) alarm threshold for given ARL (mean monitoring) xgrsr.crit <- function(k, L0, mu0=0, zr=0, hs=NULL, sided="one", MPT=FALSE, r=30) { if ( k<0 ) stop("k has to be non-negative") if ( L0<1 ) stop("L0 is too small") if ( !is.null(hs) ) { if ( hs>log(L0) ) stop("wrong headstart") } else { hs <- 2*L0 } if ( r<4 ) stop("r is too small") g <- .C("xgrsr_crit",as.double(k), as.double(L0),as.double(zr),as.double(hs),as.double(mu0),as.integer(r),as.integer(MPT), ans=double(length=1),PACKAGE="spc")$ans names(g) <- "g" return (g) } spc/R/xshewhartrunsrules.arl.R0000644000175100001440000000062311171572350016161 0ustar hornikusers xshewhartrunsrules.arl <- function(mu, c=1, type="12") { # Shewhart chart if (type=="1") { p0 <- pnorm( 3*c, mean=mu ) - pnorm( -3*c, mean=mu) arls <- 1/(1-p0) } # ditto with runs rules if (type!="1") { Q <- xshewhartrunsrules.matrix(mu, c=c, type=type) dimQ <- nrow(Q) one <- rep(1, dimQ) I <- diag(1, dimQ) arls <- solve(I-Q, one) } arl <- arls[1] arl }spc/R/xs.res.ewma.pms.R0000644000175100001440000000265011532430327014354 0ustar hornikusers# Computation of res-EWMA PMS (simultaneous mean & variance monitoring) # PMS = probability of misleading signal xs.res.ewma.pms <- function(lx, cx, ls, csu, mu, sigma, type="3", alpha=0, n=5, hsx=0, rx=40, hss=1, rs=40, qm=30) { if ( lx <= 0 || lx > 1 ) stop("lx has to be between 0 and 1") if ( ls <= 0 || ls > 1 ) stop("ls has to be between 0 and 1") if ( cx <= 0 ) stop("cx has to be positive") if ( csu <= 0 ) stop("csu has to be positive") if ( sigma <= 0 ) stop("sigma must be positive") if ( !(type %in% c("3", "4")) ) stop("wrong PMS type") vice_versa <- as.numeric(type) - 3 if ( abs(alpha) > 1 ) warning("nonstationary AR(1) process") if ( n < 1 ) warning("n is too small") n <- round(n) if ( abs(hsx) > cx ) stop("wrong headstart hsx") if ( hss < 0 | hss > csu ) stop("wrong headstart hss") if ( rx < 5 ) stop("rx is too small") if ( rs <10 ) stop("rs is too small") if ( qm < 5 ) stop("qm is too small") ctyp <- 1 # later more pms <- .C("xsewma_res_pms",as.double(alpha),as.integer(n-1),as.integer(ctyp), as.double(lx),as.double(cx),as.double(hsx),as.integer(rx), as.double(ls),as.double(csu),as.double(hss),as.integer(rs), as.double(mu),as.double(sigma),as.integer(qm),as.integer(vice_versa), ans=double(length=1),PACKAGE="spc")$ans names(pms) <- "pms" return (pms) }spc/R/mewma.psi.R0000644000175100001440000000243212526404011013275 0ustar hornikusers# Computation of MEWMA steady-state pdf (multivariate mean monitoring) mewma.psi <- function(l, cE, p, type="cond", hs=0, r=20) { if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( cE<=0 ) stop("threshold c has to be positive") if ( p<1 ) stop("wrong dimension parameter") if ( hs<0 ) stop("wrong head start value") if ( r<4 ) stop("resolution too small") itype <- pmatch(tolower(type), c("cond", "cycl")) - 1 if ( is.na(itype) ) stop("wrong type of steady-state density") zeug <- .C("mewma_psi", as.double(l), as.double(cE), as.integer(p), as.integer(itype), as.double(hs), as.integer(r), ans=double(length=3*r+1), PACKAGE="spc")$ans zahl <- zeug[1] PSI <- zeug[1:r + 1] w <- zeug[1:r + r+1] z <- zeug[1:r + 2*r+1] l2 <- ( (1-l)/l )^2 fchi <- function(u, a) 2*a * dchisq( u^2/l^2, p, ncp=l2*a^2)/l^2 if ( itype == 0 ) psi <- Vectorize(function(x) sum( w * PSI * fchi(sqrt(x), z))/zahl, "x") if ( itype == 1 ) { if ( hs < 1e-9 ) psi <- Vectorize(function(x) dchisq( x/l^2, p)/l^2 / zahl + sum( w * PSI * fchi(sqrt(x), z) ), "x") if ( hs >= 1e-9 ) psi <- Vectorize(function(x) fchi(sqrt(x), hs) / zahl + sum( w * PSI * fchi(sqrt(x), z) ), "x") } psi }spc/R/phat.ewma.arl.R0000644000175100001440000000272512513266160014052 0ustar hornikusers# Computation of EWMA phat ARLs phat.ewma.arl <- function(lambda, ucl, mu, n, z0, sigma=1, type="known", LSL=-3, USL=3, N=15, qm=25, ntype="coll") { if ( lambda <= 0 || lambda > 1 ) stop("lambda has to be between 0 and 1") p.star <- pnorm( LSL ) + pnorm( -USL ) if ( type == "known" ) { if ( ucl <= p.star ) stop("ucl must be larger than p.star") } if ( type == "estimated" ) { p.star <- 0 if ( ucl <= 0 ) stop("ucl must be positive") } if ( ucl >= 1 ) stop("ucl must be smaller than 1") if ( n < 1 ) stop("n must be >= 1") if ( z0 < p.star | z0 > ucl ) stop("wrong headstart") if ( sigma<1e-12 ) stop("sigma much too small") ctyp <- -1 + pmatch(tolower(type), c("known", "estimated")) if ( is.na(ctyp) ) stop("invalid sigma mode") if ( LSL >= USL ) stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)") if ( N < 2 ) stop("N too small") if ( qm < 5 ) stop("qm too small") ntyp <- -1 + pmatch(tolower(ntype), c("coll", "markov")) if ( is.na(ntyp) ) stop("wrong label for numerical algorithm") arl <- .C("ewma_phat_arl_coll", as.double(lambda), as.double(ucl), as.double(mu), as.double(sigma), as.integer(n), as.double(z0), as.integer(ctyp), as.double(LSL), as.double(USL), as.integer(N), as.integer(qm), as.integer(ntyp), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- "arl" arl }spc/R/scusum.arl.R0000644000175100001440000000243012201735014013467 0ustar hornikusers# Computation of CUSUM ARLs (variance monitoring) scusum.arl <- function(k, h, sigma, df, hs=0, sided="upper", k2=NULL, h2=NULL, hs2=0, r=40, qm=30, version=2) { if ( k<0 ) stop("k has to be non-negative") if ( h<=0 ) stop("h has to be positive") if ( hs<0 | hs>h ) stop("wrong headstart") if ( sided=="two" ) { if ( is.null(k2) | is.null(h2) ) stop("in case of a two-sided CUSUM scheme one has to define two sets of (k,h,hs)") if ( k2<0 ) stop("k2 has to be non-negative") if ( h2<=0 ) stop("h2 has to be positive") if ( hs2<0 | hs2>h2 ) stop("wrong headstart") } if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1 if ( is.na(ctyp) ) stop("invalid cusum type") if ( r<10 ) stop("r is too small") if ( qm<10 ) stop("qm is too small") arl <- .C("scusum_arl", as.integer(ctyp), as.double(k), as.double(h), as.double(hs), as.double(sigma), as.integer(df), as.double(k2), as.double(h2), as.double(hs2), as.integer(r), as.integer(qm), as.integer(version), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- "arl" arl } spc/R/xsewma.arl.R0000644000175100001440000000277212047703060013471 0ustar hornikusers# Computation of EWMA ARLs (simultaneous mean & variance monitoring) xsewma.arl <- function(lx, cx, ls, csu, df, mu, sigma, hsx=0, Nx=40, csl=0, hss=1, Ns=40, s2.on=TRUE, sided="upper", qm=30) { if (lx<=0 | lx>1) stop("lx has to be between 0 and 1") if (ls<=0 | ls>1) stop("ls has to be between 0 and 1") if (cx<=0) stop("cx has to be positive") if (csu<=0) stop("csu has to be positive") if (csl<0) stop("clu has to be non-negative") if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") s_squared <- as.numeric(s2.on) if ( !(s_squared %in% c(0,1)) ) stop("wrong value for s2.on") if ( abs(hsx)>cx ) stop("wrong headstart hsx") if ( hsscsu ) stop("wrong headstart hss") if (Nx<5) stop("Nx is too small") if (Ns<10) stop("Ns is too small") if (qm<5) stop("qm is too small") ctyp <- pmatch(sided, c("upper","Rupper","two","lower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") arl <- .C("xsewma_arl",as.integer(ctyp), as.double(lx),as.double(cx),as.double(hsx),as.integer(Nx), as.double(ls),as.double(csl),as.double(csu),as.double(hss), as.integer(Ns), as.double(mu),as.double(sigma), as.integer(df),as.integer(qm), as.integer(s_squared), ans=double(length=1),PACKAGE="spc")$ans names(arl) <- "arl" return (arl) } spc/R/xewma.ad.R0000644000175100001440000000235612536065307013122 0ustar hornikusers# Computation of EWMA steady-state ARLs (mean monitoring) xewma.ad <- function(l, c, mu1, mu0=0, zr=0, z0=0, sided="one", limits="fix", steady.state.mode="conditional", r=40) { if ( l<=0 || l>1 ) stop("l has to be between 0 and 1") if ( c<=0 ) warning("usually, c has to be positive") if ( zr>c & sided=="one" ) stop("wrong reflexion border") if ( r<4 ) stop("r is too small") ctyp <- pmatch(sided, c("one", "two")) - 1 if (is.na(ctyp)) stop("invalid ewma type") ltyp <- pmatch(limits, c("fix","vacl","fir","both","Steiner","stat")) - 1 if ( is.na(ltyp) ) stop("invalid limits type") if ( (sided=="one") & !(limits %in% c("fix", "vacl", "stat")) ) stop("not supported for one-sided EWMA (not reasonable or not implemented yet") styp <- pmatch(steady.state.mode, c("conditional", "cyclical")) - 1 if (is.na(styp)) stop("invalid steady.state.mode") if ( abs(z0) > abs(c) ) stop("wrong restarting value") ad <- .C("xewma_ad", as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.double(mu0), as.double(mu1), as.double(z0), as.integer(ltyp), as.integer(styp), as.integer(r), ans=double(length=1), PACKAGE="spc")$ans names(ad) <- "ad" return (ad) } spc/R/sewma.sf.prerun.R0000644000175100001440000000261612052737443014452 0ustar hornikusers# Computation of EWMA survival function (variance monitoring) with pre-run uncertainty sewma.sf.prerun <- function(n, l, cl, cu, sigma, df1, df2, hs=1, sided="upper", qm=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE) { if ( n < 1 ) stop("n has to be a natural number") if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1") if ( cu<=0 ) stop("cu has to be positive") if ( cl<0 ) stop("cl has to be non-negative") if ( sided!="upper" & cl<1e-6 ) stop("cl is too small") if ( sigma<=0 ) stop("sigma must be positive") if ( df1<1 ) stop("df1 must be larger than or equal to 1") if ( df2<1 ) stop("df2 must be larger than or equal to 1") if ( hscu ) stop("wrong headstart hs") ctyp <- pmatch(sided, c("upper","Rupper","two","Rlower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") if ( qm<5 ) stop("qm is too small") if ( qm.sigma<4 ) stop("qm.sigma is too small") if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") sf <- .C("sewma_sf_prerun", as.integer(ctyp), as.double(l), as.double(cl), as.double(cu), as.double(hs), as.double(sigma), as.integer(df1), as.integer(qm), as.integer(n), as.integer(df2), as.integer(qm.sigma), as.double(truncate), as.integer(tail_approx), ans=double(length=n),PACKAGE="spc")$ans names(sf) <- NULL sf } spc/R/mewma.ad.R0000644000175100001440000000273112543256771013111 0ustar hornikusers# Computation of MEWMA steady-state ARLs (multivariate mean monitoring) mewma.ad <- function(l, cE, p, delta=0, r=20, n=20, type="cond", hs=0, ntype=NULL, qm0=20, qm1=qm0) { if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( cE<=0 ) stop("threshold c has to be positive") if ( p<1 ) stop("wrong dimension parameter") if ( delta<0 ) stop("wrong magnitude value") if ( r<4 ) stop("resolution too small") if ( n<5 ) stop("more quadrature nodes needed") itype <- pmatch(tolower(type), c("cond", "cycl")) - 1 if ( is.na(itype) ) stop("wrong type of steady-state density") if ( hs<0 ) stop("wrong head start value") if ( r<4 ) stop("resolution too small") if ( qm0<5 ) stop("more quadrature nodes needed") if ( qm1<5 ) stop("more quadrature nodes needed") if ( is.null(ntype) ) { if ( delta <1e-10 ) { ntype <- "gl2" } else { if ( p==2 ) { ntype <- "gl3" } else { ntype <- "gl5" } } } qtyp <- pmatch(tolower(ntype), c("gl", "co", "ra", "cc", "mc", "sr", "co2", "gl2", "gl3", "gl4", "gl5", "co3", "co4")) - 1 if ( is.na(qtyp) ) stop("invalid type of numerical algorithm") ad <- .C("mewma_ad", as.double(l), as.double(cE), as.integer(p), as.double(delta), as.integer(r), as.integer(n), as.integer(itype), double(hs), as.integer(qtyp), as.integer(qm0), as.integer(qm1), ans=double(length=1), PACKAGE="spc")$ans names(ad) <- NULL ad }spc/R/sewma.q.prerun.R0000644000175100001440000000274512053651470014301 0ustar hornikusers# Computation of EWMA quantiles (variance monitoring) with pre-run uncertainty sewma.q.prerun <- function(l, cl, cu, sigma, df1, df2, alpha, hs=1, sided="upper", r=40, qm=30, qm.sigma=30, truncate=1e-10) { if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1") if ( cu<=0 ) stop("cu has to be positive") if ( cl<0 ) stop("cl has to be non-negative") if ( sided!="upper" & cl<1e-6 ) stop("cl is too small") if ( sigma<=0 ) stop("sigma must be positive") if ( df1<1 ) stop("df1 must be larger than or equal to 1") if ( df2<1 ) stop("df2 must be larger than or equal to 1") if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)") if ( hscu ) stop("wrong headstart hs") ctyp <- pmatch(sided, c("upper","Rupper","two","Rlower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") if ( r<10 ) stop("r is too small") if ( qm<5 ) stop("qm is too small") if ( qm.sigma<4 ) stop("qm.sigma is too small") if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") quant <- .C("sewma_q_prerun", as.integer(ctyp), as.double(l), as.double(cl), as.double(cu), as.double(alpha), as.double(hs), as.double(sigma), as.integer(df1), as.integer(r), as.integer(qm), as.integer(df2), as.integer(qm.sigma), as.double(truncate), ans=double(length=1),PACKAGE="spc")$ans names(quant) <- "q" quant }spc/R/xcusum.arl.R0000644000175100001440000000157112100227067013503 0ustar hornikusers# Computation of CUSUM ARLs (mean monitoring) xcusum.arl <- function(k, h, mu, hs=0, sided="one", method="igl", q=1, r=30) { if (k<0) stop("k has to be non-negative") if (h<=0) stop("h has to be positive") if ( hs<0 | (sided=="two" & hs>h/2+k) | (sided=="one" & hs>h) ) stop("wrong headstart") if (r<4) stop("r is too small") ctyp <- pmatch(sided, c("one", "two", "Crosier")) - 1 if (is.na(ctyp)) stop("invalid cusum type") mtyp <- pmatch(method, c("igl", "mc")) - 1 if (is.na(mtyp)) stop("invalid method") q <- round(q) if (q<1) stop("wrong change point position (q)") arl <- .C("xcusum_arl", as.integer(ctyp), as.double(k), as.double(h), as.double(hs), as.double(mu), as.integer(q), as.integer(r), as.integer(mtyp), ans=double(length=q), PACKAGE="spc")$ans names(arl) <- NULL return (arl) } spc/R/tol.lim.fac.R0000644000175100001440000000113210110211426013470 0ustar hornikusers# Computation of 2-sided tolerance limits factors tol.lim.fac <- function(n,p,a,mode="WW",m=30) { if (n<2) stop("n has to be larger than 1") if (p<=0 | p>=1) stop("p has to be in (0,1)") if (a<=0 | a>=1) stop("a has to be in (0,1)") mtype <- pmatch(mode, c("WW", "exact")) - 1 if (is.na(mtype)) stop("invalid mode type") if (m<10) stop("m has to be at least 10") tlf <- .C("tol_lim_fac",as.integer(n),as.double(p), as.double(a),as.integer(mtype),as.integer(m), ans=double(length=1),PACKAGE="spc")$ans names(tlf) <- "k" return (tlf) } spc/R/xewma.q.R0000644000175100001440000000265712343165333012776 0ustar hornikusers# Computation of EWMA quantiles (mean monitoring) xewma.q <- function(l, c, mu, alpha, zr=0, hs=0, sided="two", limits="fix", q=1, r=40) { if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1") if ( c<=0 ) warning("usually, c has to be positive") if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)") if ( zr > c & sided == "one") stop("wrong reflexion border") if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) ) warning("unusual headstart") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat", "test")) if (is.na(ltyp)) stop("invalid limits type") if ( (sided=="one") & !( limits %in% c("fix", "vacl", "stat") ) ) stop("not supported for one-sided EWMA (not reasonable or not implemented yet") if ( r < 4 ) stop("r is too small") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") quant <- .C("xewma_q", as.integer(ctyp), as.double(l), as.double(c), as.double(alpha), as.double(zr), as.double(hs), as.double(mu), as.integer(ltyp), as.integer(r), as.integer(q), ans=double(length=1),PACKAGE="spc")$ans names(quant) <- "q" quant } spc/R/xsewma.q.R0000644000175100001440000000260312052660153013145 0ustar hornikusers# Computation of EWMA RL quantiles (simultaneous mean & variance monitoring) xsewma.q <- function(lx, cx, ls, csu, df, alpha, mu, sigma, hsx=0, Nx=40, csl=0, hss=1, Ns=40, sided="upper", qm=30) { if ( lx<=0 | lx>1 ) stop("lx has to be between 0 and 1") if ( ls<=0 | ls>1 ) stop("ls has to be between 0 and 1") if ( cx<=0 ) stop("cx has to be positive") if ( csu<=0 ) stop("csu has to be positive") if ( df<1 ) stop("df must be larger than or equal to 1") if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)") if ( sigma<=0 ) stop("sigma must be positive") if ( abs(hsx)>cx ) stop("wrong headstart hsx") if ( Nx<5 ) stop("Nx is too small") if ( csl<0 ) stop("clu has to be non-negative") if ( hsscsu ) stop("wrong headstart hss") if ( Ns<10 ) stop("Ns is too small") ctyp <- pmatch(sided, c("upper","two")) - 1 if (is.na(ctyp)) stop("invalid ewma type") if ( qm<5 ) stop("qm is too small") quant <- .C("xsewma_q",as.integer(ctyp),as.double(alpha), as.double(lx),as.double(cx),as.double(hsx),as.integer(Nx), as.double(ls),as.double(csl),as.double(csu),as.double(hss),as.integer(Ns), as.double(mu),as.double(sigma), as.integer(df),as.integer(qm), ans=double(length=1),PACKAGE="spc")$ans names(quant) <- "q" quant } spc/R/pphat.R0000644000175100001440000000176012506050117012516 0ustar hornikuserspphat <- function(q, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30) { if ( n < 1 ) stop("n must be >= 1") if ( sigma<1e-10 ) stop("sigma much too small") ctyp <- -1 + pmatch(type, c("known", "estimated")) if ( is.na(ctyp) ) stop("invalid sigma mode") if ( LSL >= USL ) stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)") if ( nodes<2 ) stop("far too less nodes") p.star <- pnorm( LSL/sigma ) + pnorm( -USL/sigma ) if ( type == "estimated" ) p.star <- 0 cdf <- rep(NA, length(q)) for ( i in 1:length(q) ) { cdf[i] <- 0 if ( q[i] >= 1 ) cdf[i] <- 1 if ( p.star g ) stop("wrong headstart") } else { hs <- 2*g } q <- round(q) if ( q < 1 ) stop("wrong change point position (q)") if ( r < 4 ) stop("r is too small") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid grsr type") arl <- .C("xgrsr_arl", as.integer(ctyp), as.double(k), as.double(g), as.double(zr), as.double(hs), as.double(mu), as.integer(q), as.integer(r), as.integer(MPT), ans=double(length=q), PACKAGE="spc")$ans names(arl) <- NULL return (arl) }spc/R/scusum.crit.R0000644000175100001440000000270612202513713013661 0ustar hornikusers# Computation of CUSUM decision intervals -- alarm thresholds -- (variance monitoring) scusum.crit <- function(k, L0, sigma, df, hs=0, sided="upper", mode="eq.tails", k2=NULL, hs2=0, r=40, qm=30) { if ( k<0 ) stop("k has to be non-negative") if ( L0<1 ) stop("L0 is too small") if ( hs<0 ) stop("wrong headstart") if ( sided=="two" ) { if ( is.null(k2) ) stop("in case of a two-sided CUSUM scheme one has to define two reference values") if ( k2<0 ) stop("k2 has to be non-negative") if ( hs2<0 ) stop("wrong headstart") } if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1 if ( is.na(ctyp) ) stop("invalid cusum type") ltyp <- pmatch(mode, c("eq.tails", "unbiased")) - 1 if ( is.na(ltyp) ) stop("invalid limits cusum type") if ( r<10 ) stop("r is too small") if ( qm<10 ) stop("qm is too small") a.length <- 1 if ( sided=="two" ) a.length <- 2 h <- .C("scusum_crit", as.integer(ctyp), as.double(k), as.double(L0), as.double(hs), as.double(sigma), as.integer(df), as.integer(ltyp), as.double(k2), as.double(hs2), as.integer(r), as.integer(qm), ans=double(length=a.length), PACKAGE="spc")$ans if ( sided=="two" ) { names(h) <- c("hl","hu") } else { names(h) <- "h" } h } spc/R/xDcusum.arl.R0000644000175100001440000000200511177134517013612 0ustar hornikusers# Computation of CUSUM ARLs (drift monitoring) xDcusum.arl <- function(k, h, delta, hs=0, sided="one", mode="Gan", m=NULL, q=1, r=30, with0=FALSE) { if (k<0) stop("k has to be non-negative") if (h<=0) stop("h has to be positive") if ( hs<0 | (sided=="two" & hs>h/2+k) | (sided=="one" & hs>h/2+k) ) stop("wrong headstart") if (r<4) stop("r is too small") if ( is.null(m) ) { m <- 0 } else { if ( m<1 ) stop("m is too small") } ctyp <- pmatch(sided, c("one", "two")) - 1 if (is.na(ctyp)) stop("invalid cusum type") cmode <- pmatch(mode, c("Gan", "Knoth")) - 1 if (is.na(cmode)) stop("invalid algorithm mode") q <- round(q) if (q<1) stop("wrong change point position (q)") arl <- .C("xDcusum_arl",as.integer(ctyp),as.double(k), as.double(h),as.double(hs),as.double(delta),as.integer(m), as.integer(r),as.integer(with0),as.integer(cmode),as.integer(q), ans=double(length=1),PACKAGE="spc")$ans names(arl) <- "arl" return (arl) } spc/R/lns2ewma.arl.R0000644000175100001440000000222712203114304013677 0ustar hornikusers# Computation of EWMA ARLs (variance monitoring) based on ln S^2 lns2ewma.arl <- function(l, cl, cu, sigma, df, hs=NULL, sided="upper", r=40) { #mitte <- -1/df - 1/3/df^2 + 2/15/df^4 # approx following Crowder/Hamilton mitte <- log(2/df) + digamma(df/2) if ( is.null(cl) ) cl <- mitte if ( is.null(cu) ) cu <- mitte if ( is.null(hs) ) hs <- mitte if ( l<=0 || l>1 ) stop("l has to be between 0 and 1") #if ( cu < mitte ) stop(paste("cu has to be larger than", mitte)) #if ( cl > mitte ) stop(paste("cl has to be smaller than", mitte)) if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") if ( hscu+1e-9 ) stop("wrong headstart") ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") if ( r<10 ) stop("r is too small") arl <- .C("lns2ewma_arl", as.integer(ctyp), as.double(l), as.double(cl), as.double(cu), as.double(hs), as.double(sigma), as.integer(df), as.integer(r), ans=double(length=1),PACKAGE="spc")$ans names(arl) <- "arl" return (arl) } spc/R/s.res.ewma.arl.R0000644000175100001440000000162511546671665014165 0ustar hornikusers# Computation of res-EWMA ARLs (scale monitoring) s.res.ewma.arl <- function(l,cu,sigma,mu=0,alpha=0,n=5,hs=1,r=40,qm=30) { if ( l <= 0 || l > 1 ) stop("l has to be between 0 and 1") if ( cu <= 0 ) warning("usually, cu has to be positive") if ( sigma <= 0 ) stop("sigma must be positive") if ( abs(alpha) > 1 ) warning("nonstationary AR(1) process") if ( n < 2 ) warning("n is too small") n <- round(n) if ( abs(hs) > cu ) warning("unusual headstart") if ( r < 4 ) stop("r is too small") if ( qm < 10 ) stop("qm is too small") ctyp <- 1 # later more arl <- .C("s_res_ewma_arl",as.double(alpha),as.integer(n-1), as.integer(ctyp),as.double(l), as.double(cu),as.double(hs), as.double(sigma),as.double(mu),as.integer(r),as.integer(qm), ans=double(length=1),PACKAGE="spc")$ans names(arl) <- "arl" return (arl) } spc/R/xcusum.sf.R0000644000175100001440000000130411721204072013326 0ustar hornikusers# Computation of CUSUM survival function (mean monitoring) xcusum.sf <- function(k, h, mu, n, hs=0, sided="one", r=40) { if ( k < 0 ) stop("k has to be non-negative") if ( h <= 0 ) stop("h has to be positive") if ( hs < 0 | (sided=="two" & hs>h/2+k) | (sided=="one" & hs>h/2+k) ) stop("wrong headstart") if ( n < 1 ) stop("n has to be a natural number") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid cusum type") if ( r < 4 ) stop("r is too small") sf <- .C("xcusum_sf", as.integer(ctyp), as.double(k), as.double(h), as.double(hs), as.double(mu), as.integer(r), as.integer(n), ans=double(length=n),PACKAGE="spc")$ans names(sf) <- NULL sf } spc/R/xDgrsr.arl.R0000644000175100001440000000216411177145337013443 0ustar hornikusers# Computation of GRSR (Girshick, Rubin, Shiryaev, Roberts) ARLs (drift monitoring) xDgrsr.arl <- function(k, g, delta, zr=0, hs=NULL, sided="one", m=NULL, mode="Gan", q=1, r=30, with0=FALSE) { if (k<0) stop("k has to be non-negative") if (g<=0) stop("g has to be positive") if (zr>g) stop("zr has to be smaller than g") if ( !is.null(hs) ) { if ( hs>g ) stop("wrong headstart") } else { hs <- 2*g # mimics hs = -inf } ctyp <- pmatch(sided, c("one", "two")) - 1 if (is.na(ctyp)) stop("invalid grsr type") if (r<4) stop("r is too small") if ( is.null(m) ) { m <- 0 } else { if ( m<1 ) stop("m is too small") } cmode <- pmatch(mode, c("Gan", "Knoth")) - 1 if (is.na(cmode)) stop("invalid algorithm mode") q <- round(q) if (q<1) stop("wrong change point position (q)") arl <- .C("xDgrsr_arl",as.double(k), as.double(g),as.double(zr),as.double(hs),as.double(delta),as.integer(m), as.integer(r),as.integer(with0),as.integer(cmode),as.integer(q), ans=double(length=1),PACKAGE="spc")$ans names(arl) <- "arl" return (arl) } spc/R/xgrsr.ad.R0000644000175100001440000000117612077526316013147 0ustar hornikusers# Computation of GRSR (Girshick, Rubin, Shiryaev, Roberts) steady-state ARLs (mean monitoring) xgrsr.ad <- function(k, g, mu1, mu0=0, zr=0, sided="one", MPT=FALSE, r=30) { if (k<0) stop("k has to be non-negative") if (g<0) stop("g has to be positive") if (r<4) stop("r is too small") ctyp <- pmatch(sided, c("one", "two")) - 1 if (is.na(ctyp)) stop("invalid grsr type") ad <- .C("xgrsr_ad",as.integer(ctyp),as.double(k), as.double(g),as.double(mu0),as.double(mu1),as.double(zr),as.integer(r),as.integer(MPT), ans=double(length=1),PACKAGE="spc")$ans names(ad) <- "ad" return(ad) } spc/R/p.ewma.arl.R0000644000175100001440000000175211641340646013357 0ustar hornikusers# Computation of attribute p EWMA ARLs p.ewma.arl <- function(lambda, ucl, n, p, z0, d.res=1, r.mode="ieee.round", i.mode="integer") { i.r.mode <- -2 + pmatch(r.mode, c("gan.floor", "floor", "ceil", "ieee.round", "round", "mix")) i.i.mode <- -1 + pmatch(i.mode, c("integer", "half")) if ( lambda <= 0 || lambda > 1 ) stop("lambda has to be between 0 and 1") if ( ucl < 0 ) stop("ucl must be larger than 0") if ( n < 1 ) stop("n must be >= 1") if ( 0 > p | p > 1 ) stop("wrong value for p") if ( z0 < 0 | z0 > ucl ) stop("wrong headstart") if ( d.res < 1 ) stop("d.res too small") if ( is.na(i.r.mode) ) stop("invalid round mode") if ( is.na(i.i.mode) ) stop("invalid interval mode") arl <- .C("ewma_p_arl_be", as.double(lambda), as.double(ucl), as.integer(n), as.double(p), as.double(z0), as.integer(d.res), as.integer(i.r.mode), as.integer(i.i.mode), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- "arl" return (arl) }spc/R/sewma.crit.R0000644000175100001440000000376512210715530013464 0ustar hornikusers# Computation of EWMA critical values for given ARL (variance monitoring) sewma.crit <- function(l, L0, df, sigma0=1, cl=NULL, cu=NULL, hs=NULL, s2.on=TRUE, sided="upper", mode="fixed", ur=4, r=40, qm=30) { mitte <- sqrt( 2/df ) * gamma( (df+1)/2 )/ gamma( df/2 ) if ( is.null(hs) ) { if ( s2.on ) { hs <- 1 } else { hs <- mitte } } cu0 <- cl0 <- 0 if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( L0<1 ) stop("L0 is too small") if ( df<1 ) stop("df must be positive") if ( sigma0<=0 ) stop("sigma0 must be positive") if ( sided=="Rupper" ) { if ( is.null(cl) ) stop("set cl") if ( cl<=0 ) stop("cl must be positive") cl0 <- cl if ( hs1 ) stop("l has to be between 0 and 1") if ( L0<1 ) stop("L0 is too small") if ( alpha<=0 | alpha>=1 ) stop("quantile level alpha must be in (0,1)") if ( df<1 ) stop("df must be positive") if ( sigma0<=0 ) stop("sigma0 must be positive") if ( sided=="Rupper" ) { if ( is.null(cl) ) stop("set cl") if ( cl<=0 ) stop("cl must be positive") cl0 <- cl if ( hs= 1 ) stop("alpha has to be between -1 and 1") if ( cS <= 0 ) stop("cS has to be positive") arl <- .C("xshewhart_ar1_arl", as.double(alpha), as.double(cS), as.double(delta), as.integer(N1), as.integer(N2), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- NULL arl } spc/R/xcusum.q.R0000644000175100001440000000140712050201431013152 0ustar hornikusers# Computation of CUSUM quantiles (mean monitoring) xcusum.q <- function(k, h, mu, alpha, hs=0, sided="one", r=40) { if ( k < 0 ) stop("k has to be non-negative") if ( h <= 0 ) stop("h has to be positive") if ( hs<0 | (sided=="two" & hs>h/2+k) | (sided=="one" & hs>h/2+k) ) stop("wrong headstart") if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid cusum type") if ( r < 4 ) stop("r (dimension of Markov chain) is too small") quant <- .C("xcusum_q", as.integer(ctyp), as.double(k),as.double(h), as.double(alpha), as.double(hs), as.double(mu), as.integer(r), ans=double(length=1),PACKAGE="spc")$ans names(quant) <- "q" quant } spc/R/x.res.ewma.arl.R0000644000175100001440000000137611532414626014160 0ustar hornikusers# Computation of res-EWMA ARLs (mean monitoring) x.res.ewma.arl <- function(l, c, mu, alpha=0, n=5, hs=0, r=40) { if ( l <= 0 || l > 1 ) stop("l has to be between 0 and 1") if ( c <= 0 ) warning("usually, c has to be positive") if ( abs(alpha) > 1 ) warning("nonstationary AR(1) process") if ( n < 1 ) warning("n is too small") n <- round(n) if ( abs(hs) > c ) warning("unusual headstart") if ( r < 4 ) stop("r is too small") ctyp <- 1 # later more arl <- .C("x_res_ewma_arl",as.double(alpha),as.integer(n), as.integer(ctyp),as.double(l), as.double(c),as.double(hs), as.double(mu),as.integer(r), ans=double(length=1),PACKAGE="spc")$ans names(arl) <- "arl" return (arl) }spc/R/sewma.arl.prerun.R0000644000175100001440000000246112053200727014605 0ustar hornikusers# Computation of EWMA ARLs (variance monitoring) with pre-run uncertainty sewma.arl.prerun <- function(l, cl, cu, sigma, df1, df2, hs=1, sided="upper", r=40, qm=30, qm.sigma=30, truncate=1e-10) { if ( l<=0 || l>1 ) stop("l has to be between 0 and 1") if ( cl<0 ) stop("cl has to be non-negative") if ( cu<=0 ) stop("cu has to be positive") if ( sigma<=0 ) stop("sigma must be positive") if ( df1<1 ) stop("df1 must be larger than or equal to 1") if ( df2<1 ) stop("df2 must be larger than or equal to 1") if ( hscu ) stop("wrong headstart") ctyp <- pmatch(sided, c("upper", "Rupper", "two", "Rlower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") if ( r<10 ) stop("r is too small") if ( qm<10 ) stop("qm is too small") if ( qm.sigma<4 ) stop("qm.sigma is too small") if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") arl <- .C("sewma_arl_prerun", as.integer(ctyp), as.double(l), as.double(cl), as.double(cu), as.double(hs), as.double(sigma), as.integer(df1), as.integer(r), as.integer(qm), as.integer(df2), as.integer(qm.sigma), as.double(truncate), ans=double(length=1),PACKAGE="spc")$ans names(arl) <- "arl" return (arl) } spc/MD50000644000175100001440000002354412656106047011404 0ustar hornikusers6c7f056e082899a4ede80570f416535a *DESCRIPTION 52b9bc90dded7a5478eca569c3802b10 *NAMESPACE 938e63b937546368d2a3ad73dbc1a749 *R/dphat.R 46823b56986ca3813c49e4fc8eb421eb *R/lns2ewma.arl.R 0e2143506950183c7381613da155171f *R/lns2ewma.crit.R 72a97f0a99f28290f4b993eb35405a55 *R/mewma.ad.R eff9aaa3257443b75311852629504916 *R/mewma.arl.R c2f2bf8b2d1cc2587c2e12eeec538387 *R/mewma.arl.f.R e68659aaacd0fe568034de97d3ced575 *R/mewma.crit.R d635b9dbb2f078b5fd208327b7f9d678 *R/mewma.psi.R 086bea677bfa69d34d721ca739b8387f *R/p.ewma.arl.R e9cfc122ce8e168cc01df062d400d6bf *R/phat.ewma.arl.R a65306a9a11b5e3dac9128f086615469 *R/phat.ewma.crit.R cde50d6572735dec15253ac814d1294b *R/phat.ewma.lambda.R 8493c6ffe635deab1f9b9120b14e7330 *R/pphat.R 76dbd6c5db0fb64dfe91f76b9aab6312 *R/qphat.R 85f5c1605413c07024e732ffc33fb789 *R/quadrature.nodes.weights.R 317e34aaffbe5a167d6f84b92b225dc1 *R/s.res.ewma.arl.R fcca944c36e65ab9046977f17f0cd706 *R/scusum.arl.R c738ce11a5abce3a5756649839160bd5 *R/scusum.crit.R 2acc113d9f2281a5ef782528fd90df65 *R/sewma.arl.R f0409e488a90344e564cb55f89445e74 *R/sewma.arl.prerun.R f3f68cd4d3b1d75b7f22b145115e4540 *R/sewma.crit.R c5bcbcb0cd59edcaed4670bea5008eb1 *R/sewma.crit.prerun.R b49219549f661cd0ec55ecbfa905bb93 *R/sewma.q.R 8350a1a84ae6212b6b25fb45475acaae *R/sewma.q.crit.R e526b39efbc216bba1632d9b83ab8522 *R/sewma.q.crit.prerun.R db8fbd6c63492a8a5ae16732e32d95f3 *R/sewma.q.prerun.R 2d6e3631fff009282f8df33565f3c7d8 *R/sewma.sf.R 83d34c77f784b344f4dd063e0f487500 *R/sewma.sf.prerun.R fd57e3a90136ae5fca614785a32eb051 *R/tol.lim.fac.R cfee1a6bf5558cf8fa9d8ebe13a5a64b *R/x.res.ewma.arl.R 4b7c2c8735cbd08cd1d5b8956260c8cf *R/xDcusum.arl.R d6682d01336ddd3a6e9543534fd03ccc *R/xDewma.arl.R e4c99cfb1af2723fd0ead1f9972032ab *R/xDgrsr.arl.R 9d934ae10d381a8c6cba9bb95ac550be *R/xDshewhartrunsrules.arl.R 94c819e0b4d5321fc2c8d37847674ce2 *R/xDshewhartrunsrulesFixedm.arl.R a5c7c2978c97e15c3e71db7e970714e1 *R/xcusum.ad.R 6de6a8e9011734b608c9438ae9233cc9 *R/xcusum.arl.R 3ece9667f05deb05a7ecf3bff05bec59 *R/xcusum.crit.L0L1.R 159d295a0d1998df9504da0a0a820fde *R/xcusum.crit.L0h.R dc00420d8558cd9aa8a72799d57792ec *R/xcusum.crit.R f402ec38d884f261dc9ba5b74716d8ac *R/xcusum.q.R 185c396ccf056bd67841612b7db5c376 *R/xcusum.sf.R 35ee63dccee47665a0f6ec3b58a56fe4 *R/xewma.ad.R 370e31d24f67acf39f935bfc77f9a88f *R/xewma.arl.R 2384b100e60076bede8e4d667fbe29b9 *R/xewma.arl.prerun.R bcf9da17e5c79decfc7fe43c321cec0a *R/xewma.crit.R 6eddc14fa12e5345561913a549b852f3 *R/xewma.crit.prerun.R cf4addd85eec5780753b88bd9e2af27d *R/xewma.q.R f5c770a08813cb160003470d1808f8ad *R/xewma.q.crit.R f6a968ae9d298c40c5585b00db74b8f3 *R/xewma.q.crit.prerun.R 5738bac113bb0816739ea94fc33491c5 *R/xewma.q.prerun.R 63bc340f0e5f72bd03910aac54b87dc8 *R/xewma.sf.R b84367be01626eb8912c9fb3cf3aa12b *R/xewma.sf.prerun.R 3266bb62646ca179fbda8b5d98e155f6 *R/xgrsr.ad.R f94cb6ba4c3c528b98b09e3d53e95846 *R/xgrsr.arl.R ef4268f136ee02ccadc72b02e66759ff *R/xgrsr.crit.R 30199f064e29b335f1cf70fb054d148b *R/xs.res.ewma.arl.R 48049b56879a2d94d06d60ad44a2f440 *R/xs.res.ewma.pms.R 3bd74fbfc2191fedce471f23d056bb17 *R/xsewma.arl.R 7555235086a9b36f11505121fcb4d223 *R/xsewma.crit.R 97b870b8e3fb5ee15acaba3236f6c7c8 *R/xsewma.q.R bdc534ec6379c94bcf559f279d14e49f *R/xsewma.q.crit.R f35fe332fd717ed54d72ee9c7b69b015 *R/xsewma.sf.R b9faf08ba81def9017f9ae184c03a9c8 *R/xshewhart.ar1.arl.R 24bbe9df9f8a6abe6c497ed01a17d397 *R/xshewhartrunsrules.ad.R 4facffeca81aa3f9ac0f2b9e8089902d *R/xshewhartrunsrules.arl.R 6301fa5dedf8ba0804e7a03914836094 *R/xshewhartrunsrules.crit.R 886226d03f84cfbcef6d779d76df6c1b *R/xshewhartrunsrules.matrix.R e3adc64172316afd9a2ad78b611cb797 *R/xtcusum.arl.R b342f3113b2c398924824e5c15c0162a *R/xtewma.ad.R 3271e757c33e48d87e87f773ad9f6364 *R/xtewma.arl.R ed29d98eef38e0ae9c70d81016ef3a4b *R/xtewma.q.R 456f24087f1d58b0bee856fe348ec065 *R/xtewma.q.crit.R a4f288e5b90e0ad70393a46f64c89695 *R/xtewma.sf.R 08424d9ece6e6b1be221fdda65e878d0 *man/dphat.Rd 271ba55c1ce16a250f99878b44cdb563 *man/lns2ewma.crit.Rd 88c66319a2af8f03cd10de612085d4cd *man/lns2sewma.arl.Rd b0472b08082e44819247c6429df4f9a7 *man/mewma.arl.Rd b5010cff3d7f8e4325d4f332af3cc235 *man/mewma.crit.Rd 623eb1c5b2ee8a9595976ab2678d350d *man/mewma.psi.Rd 033dc9ed7c40653ab7774c5e1ce0d3ae *man/p.ewma.arl.Rd 7bdda3d7ac509853fab1dc68a1e99ba3 *man/phat.ewma.arl.Rd d57dfa5c57e9ec103545a443d203d675 *man/quadrature.nodes.weights.Rd 0d471bf118ec7405bbdc4fd8106c70c9 *man/scusum.arl.Rd 686d334f1eeb578afbdeb7f56ccb9249 *man/scusum.crit.Rd 015f2d7adf1b312393a1deff41b82f0b *man/sewma.arl.Rd 88486e28395605d39cec22b4189ae192 *man/sewma.arl.prerun.Rd 6b79d31a43f78798b0b9a973afddaf63 *man/sewma.crit.Rd 68095ff731ea8d0188595143ea8e83ae *man/sewma.crit.prerun.Rd d672fd509f2abcbff612643366cbd6b3 *man/sewma.q.Rd a2a2d1f99d9d899af01cf9a5e8170911 *man/sewma.q.prerun.Rd 1b5002479922de9c6d0a529df85fb448 *man/sewma.sf.Rd 32a93216099543d787804a2280ee3dc6 *man/sewma.sf.prerun.Rd 7640f6bb7702bfb6c0bae1cfe1118a63 *man/tol.lim.fact.Rd e06f37c1ade9acc3a5ed5765775df56a *man/xDcusum.arl.Rd 59f2f599371c9489d68d9f31a0e343b6 *man/xDewma.arl.Rd 6ffba75547def5cb7dc49d23b0bdc617 *man/xDgrsr.arl.Rd e3a1ea345ab1806c88b68f4ac70e9d82 *man/xDshewhartrunsrules.arl.Rd c6364ba0d27305c53a5f9726e21cb9ba *man/xcusum.ad.Rd cf68f8128736d06285e30ec9ffedb28d *man/xcusum.arl.Rd 5628878c49afd037b1a17fdbd56620a8 *man/xcusum.crit.L0L1.Rd 7833ee5a4777ec8c983e416db55aa11a *man/xcusum.crit.L0h.Rd f35459613a412ea993676ce3a6ead850 *man/xcusum.crit.Rd e5459a7bf1a11e07e20e1e2635092c07 *man/xcusum.q.Rd 08f2cec21bdf235a8c7ffb5981930203 *man/xcusum.sf.Rd f67cefd8835b8230cb0c16dd65517579 *man/xewma.ad.Rd b53830c8001bc5f2c0b59ec61d0bdf5b *man/xewma.arl.Rd ea602bd2f4981650e51ddd94074b8f81 *man/xewma.arl.prerun.Rd b4138765aae313c0febf5058939bb9d8 *man/xewma.crit.Rd 2f76da8ad4be6d7f2f209281416af874 *man/xewma.q.Rd b2c99083aa297992cd4c79692e3865ea *man/xewma.q.prerun.Rd 81c4afc665901d85eee2116bed7edd53 *man/xewma.sf.Rd 3f432ef08d8578afed11119d5bd9eb53 *man/xewma.sf.prerun.Rd 7c1c2e57c40e68820004d82a2fcad405 *man/xgrsr.ad.Rd 3d2057b862920530a53f0b19f0b54462 *man/xgrsr.arl.Rd 65b0074e43108c025e6f4164afa4c23b *man/xgrsr.crit.Rd 7a9b9c5f142ac513e3ca0f1a9d9474cf *man/xsewma.arl.Rd cc442af0a42b56cd24b45c6f8fe1c3e7 *man/xsewma.crit.Rd 5598a54fa64b9e912bc51c68f527d4cb *man/xsewma.q.Rd d77c99948c4c0bbefd8df24282a53cc3 *man/xsewma.sf.Rd 1e1b2afd78d8b0b2d11c9ba2ce1aa396 *man/xshewhart.ar1.arl.Rd c4a5ce003421597f181f44fded11fe3e *man/xshewhartrunsrules.arl.Rd 590dffc5dfd1d2cafa16d816ce1c913c *man/xsresewma.arl.Rd a6ed29f1da028de10edce1926c8773a7 *man/xtcusum.arl.Rd 23e1abd7d33a2a0600b67190d5fa4068 *man/xtewma.ad.Rd a0761716e88359aaced32bc28b90f70c *man/xtewma.arl.Rd 394e66d297405c8be74ecb9803bea1a8 *man/xtewma.q.Rd ff3072d7d7328bec15ae828ba355df3d *man/xtewma.sf.Rd 3a2d5892e12ec5f00c5ef5844ba4d5dc *src/allspc.c 7f3ebbeabd48d8d15b5155cb2d627b45 *src/ewma_p_arl_be.c 13a4e7af8e9d8ae22430511758649191 *src/ewma_phat_arl_coll.c e05ec9bd7cc1f2fd026b563a2e430edb *src/ewma_phat_crit_coll.c 30d2f093b1f54044ea0899dda2f1bd36 *src/ewma_phat_lambda_coll.c 75d7d4568b9a704e70851104f1247547 *src/lns2ewma_arl.c cdec3fd6820823e934b178111270db95 *src/lns2ewma_crit.c c2a96de10e7799e646c895faa6577557 *src/mewma_ad.c 80a51e1645fa8894b6c100055bd37ca0 *src/mewma_arl.c 920643c294114fbc2ae329ce97e66282 *src/mewma_arl_f.c e055bc9dc17c7f2e40dcdf45e2dc05b6 *src/mewma_crit.c 4b3ca88dfd78cb7856e9322fe19ada66 *src/mewma_psi.c a343f3f97264c33987e3b423a0520782 *src/phat_cdf.c f98c7e364dd47f9e7a63bb27c484ce83 *src/phat_pdf.c 3cf82dbe65d6accc2443aa9cfd28c5fa *src/phat_qf.c 78d94b0dd1f7e7721c825665080cd93b *src/quadrature_nodes_weights.c 1138bbdb1fb193171d577c20cb8bb54b *src/scusum_arl.c 7043fc65d170cec221f04e13ae36914c *src/scusum_crit.c f2ff01ced990ba425fd4e712f65012bc *src/sewma_arl.c 4c920acf8afa10f0d6bde407839da097 *src/sewma_arl_prerun.c f62e235bcfffdaaf07a9293ea85261f8 *src/sewma_crit.c d6da86484517aebe4dd0d4dabb4deaaf *src/sewma_crit_prerun.c 548c06b8ece5ee78db8a79efb6d9b6d0 *src/sewma_q.c 95bde8f159dcff0f056bb59fd0d3d6e8 *src/sewma_q_crit.c 1c3dd3c3597a61b3f2bfb7dae0867fce *src/sewma_q_crit_prerun.c 8c01dd8052ec29bb2b8bc0a144c7aed4 *src/sewma_q_prerun.c dfa00954609e5b3a509a286ed48501e3 *src/sewma_res_arl.c ecf78a7adca417976353fd6cd0b1f297 *src/sewma_sf.c df8e9c91ce841335e4538292f8510f50 *src/sewma_sf_prerun.c 7d5d3b5fb77da4bc0112145513e70b07 *src/tol_lim_fac.c 60be25c27a4db0a21d84d8853c9f79f9 *src/xDcusum_arl.c e30b38fec4ae87f8ae199bf0a30b6016 *src/xDewma_arl.c 29e58e38907104709cb82387da0f5935 *src/xDgrsr_arl.c 71f32a11f8a81361e2c6b7f7bb4f58a4 *src/xcusum_ad.c 663e56b59a15d512e2a43e8ab826e1a6 *src/xcusum_arl.c eeb348dfb7c4f3b49786d5c77a56029a *src/xcusum_crit.c 5159145d823621d789a60d0f9afcd8f0 *src/xcusum_q.c c80a83da167cb4812d40b0ea4dce8f4e *src/xcusum_sf.c 6bfecdcf8570db9c713673bbc5c50c1e *src/xewma_ad.c ef94dc6fc6abc008d3200fe9074f7359 *src/xewma_arl.c 07fc786c9edbae9df4f6a405b644c0bb *src/xewma_arl_prerun.c 924e49d6f154bc51d6e70083c531a661 *src/xewma_crit.c e7d23cc20775cadaae418303bfbc8f3c *src/xewma_q.c b621caf1355258ad4d164cc8e7c98973 *src/xewma_q_prerun.c 901a9013eafee36e06a00884b00e73d9 *src/xewma_res_arl.c b50ac513bfd8b342ab58aa4e8160a549 *src/xewma_sf.c 89fe3b240172c25c37237050cb4ed78a *src/xewma_sf_prerun.c 21ea2dd23de83ac4d3a8337d247c98f3 *src/xgrsr_ad.c 2bbc7b00f38bc2db07f67f287c1dd30c *src/xgrsr_arl.c 963ff7aedda3bb085e576d835bab6c01 *src/xgrsr_crit.c 1a6b03d4e482ef7fafc01e085afc49f0 *src/xsewma_arl.c 46db106c68df8db6a078b69f6cf46244 *src/xsewma_crit.c ce6904e1ee2dd0804d1dbcf0eaec6458 *src/xsewma_q.c ec842eafa53b5f1322273285e64c1648 *src/xsewma_q_crit.c 37996b63005a89201f5562c9061fc442 *src/xsewma_res_arl.c 56cd4e09f23003a9b6b16f0f4b7eb66f *src/xsewma_res_pms.c 925ce8aa0806911a53fe25042e0d6c2b *src/xsewma_sf.c feb70c2804fbe8ead56e7c6f2d7737b7 *src/xshewhart_ar1_arl.c 2b775e05f140e34e322e2875ed100cc2 *src/xtcusum_arl.c 8116ba9aa9671a9465dd2d96b256fe92 *src/xtewma_ad.c 3ad3c9275a1a7ac90db34cd62d2af180 *src/xtewma_arl.c 1c9024238bf1e399728043b268d0eeeb *src/xtewma_q.c 5523b0f49d7bd96031aa3e0ec4791e50 *src/xtewma_sf.c spc/DESCRIPTION0000644000175100001440000000174612656106047012602 0ustar hornikusersPackage: spc Version: 0.5.3 Date: 2016-02-10 Title: Statistical Process Control -- Collection of Some Useful Functions Author: Sven Knoth Maintainer: Sven Knoth Depends: R (>= 1.8.0) Description: Evaluation of control charts by means of the zero-state, steady-state ARL (Average Run Length) and RL quantiles. Setting up control charts for given in-control ARL. The control charts under consideration are one- and two-sided EWMA, CUSUM, and Shiryaev-Roberts schemes for monitoring the mean of normally distributed independent data. ARL calculation of the same set of schemes under drift are added. Other charts and parameters are in preparation. Further SPC areas will be covered as well (sampling plans, capability indices ...). License: GPL (>= 2) URL: http://www.r-project.org NeedsCompilation: yes Packaged: 2016-02-05 14:49:17 UTC; knoth Repository: CRAN Date/Publication: 2016-02-08 13:37:59 spc/man/0000755000175100001440000000000012655133072011634 5ustar hornikusersspc/man/xsewma.arl.Rd0000644000175100001440000000745712273731355014225 0ustar hornikusers\name{xsewma.arl} \alias{xsewma.arl} \title{Compute ARLs of simultaneous EWMA control charts (mean and variance charts)} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of simultaneous EWMA control charts (based on the sample mean and the sample variance \eqn{S^2}) monitoring normal mean and variance.} \usage{xsewma.arl(lx, cx, ls, csu, df, mu, sigma, hsx=0, Nx=40, csl=0, hss=1, Ns=40, s2.on=TRUE, sided="upper", qm=30)} \arguments{ \item{lx}{smoothing parameter lambda of the two-sided mean EWMA chart.} \item{cx}{control limit of the two-sided mean EWMA control chart.} \item{ls}{smoothing parameter lambda of the variance EWMA chart.} \item{csu}{upper control limit of the variance EWMA control chart.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{mu}{true mean.} \item{sigma}{true standard deviation.} \item{hsx}{so-called headstart (enables fast initial response) of the mean chart -- do not confuse with the true FIR feature considered in xewma.arl; will be updated.} \item{Nx}{dimension of the approximating matrix of the mean chart.} \item{csl}{lower control limit of the variance EWMA control chart; default value is 0; not considered if \code{sided} is \code{"upper"}.} \item{hss}{headstart (enables fast initial response) of the variance chart.} \item{Ns}{dimension of the approximating matrix of the variance chart.} \item{s2.on}{distinguishes between \eqn{S^2}{S^2} and \eqn{S}{S} chart.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{qm}{number of quadrature nodes used for the collocation integrals.} } \details{ \code{xsewma.arl} determines the Average Run Length (ARL) by an extension of Gan's (derived from ideas already published by Waldmann) algorithm. The variance EWMA part is treated similarly to the ARL calculation method deployed for the single variance EWMA charts in Knoth (2005), that is, by means of collocation (Chebyshev polynomials). For more details see Knoth (2007).} \value{Returns a single value which resembles the ARL.} \references{ K. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{J. R. Stat. Soc., Ser. C, Appl. Stat. 35}, 151-158. F. F. Gan (1995), Joint monitoring of process mean and variance using exponentially weighted moving average control charts, \emph{Technometrics 37}, 446-453. S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. } \author{Sven Knoth} \seealso{ \code{xewma.arl} and \code{sewma.arl} for zero-state ARL computation of single mean and variance EWMA control charts, respectively. } \examples{ ## Knoth (2007) ## collocation results in Table 1 ## Monte Carlo with 10^9 replicates: 252.307 +/- 0.0078 # process parameters mu <- 0 sigma <- 1 # subgroup size n=5, df=n-1 df <- 4 # lambda of mean chart lx <- .134 # c_mu^* = .345476571 = cx/sqrt(n) * sqrt(lx/(2-lx) cx <- .345476571*sqrt(df+1)/sqrt(lx/(2-lx)) # lambda of variance chart ls <- .1 # c_sigma = .477977 csu <- 1 + .477977 # matrix dimensions for mean and variance part Nx <- 25 Ns <- 25 # mode of variance chart SIDED <- "upper" arl <- xsewma.arl(lx, cx, ls, csu, df, mu, sigma, Nx=Nx, Ns=Ns, sided=SIDED) arl } \keyword{ts} spc/man/lns2sewma.arl.Rd0000644000175100001440000000674312274004203014613 0ustar hornikusers\name{lns2ewma.arl} \alias{lns2ewma.arl} \title{Compute ARLs of EWMA ln \eqn{S^2}{S^2} control charts (variance charts)} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of EWMA control charts (based on the log of the sample variance \eqn{S^2}) monitoring normal variance.} \usage{lns2ewma.arl(l,cl,cu,sigma,df,hs=NULL,sided="upper",r=40)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{cl}{lower control limit of the EWMA control chart.} \item{cu}{upper control limit of the EWMA control chart.} \item{sigma}{true standard deviation.} \item{df}{actual degrees of freedom, corresponds to subsample size (for known mean it is equal to the subsample size, for unknown mean it is equal to subsample size minus one.} \item{hs}{so-called headstart (enables fast initial response) -- the default value (hs=NULL) corresponds to the in-control mean of ln \eqn{S^2}{S^2}.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart with reflection at \code{cl}), \code{"lower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{r}{dimension of the resulting linear equation system: the larger the better.} } \details{ \code{lns2ewma.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature.} \value{Returns a single value which resembles the ARL.} \references{ S. V. Crowder and M. D. Hamilton (1992), An EWMA for monitoring a process standard deviation, \emph{Journal of Quality Technology 24}, 12-21. S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL computation of EWMA control charts for monitoring normal mean. } \examples{ lns2ewma.ARL <- Vectorize("lns2ewma.arl", "sigma") ## Crowder/Hamilton (1992) ## moments of ln S^2 E_log_gamma <- function(df) log(2/df) + digamma(df/2) V_log_gamma <- function(df) trigamma(df/2) E_log_gamma_approx <- function(df) -1/df - 1/3/df^2 + 2/15/df^4 V_log_gamma_approx <- function(df) 2/df + 2/df^2 + 4/3/df^3 - 16/15/df^5 ## results from Table 3 ( upper chart with reflection at 0 = log(sigma0=1) ) ## original entries are (lambda = 0.05, K = 1.06, df=n-1=4) # sigma ARL # 1 200 # 1.1 43 # 1.2 18 # 1.3 11 # 1.4 7.6 # 1.5 6.0 # 2 3.2 df <- 4 lambda <- .05 K <- 1.06 cu <- K * sqrt( lambda/(2-lambda) * V_log_gamma_approx(df) ) sigmas <- c(1 + (0:5)/10, 2) arls <- round(lns2ewma.ARL(lambda, 0, cu, sigmas, df, hs=0, sided="upper"), digits=1) data.frame(sigmas, arls) ## Knoth (2005) ## compare with Table 3 (p. 351) lambda <- .05 df <- 4 K <- 1.05521 cu <- 1.05521 * sqrt( lambda/(2-lambda) * V_log_gamma_approx(df) ) ## upper chart with reflection at sigma0=1 in Table 4 ## original entries are # sigma ARL_0 ARL_-.267 # 1 200.0 200.0 # 1.1 43.04 41.55 # 1.2 18.10 19.92 # 1.3 10.75 13.11 # 1.4 7.63 9.93 # 1.5 5.97 8.11 # 2 3.17 4.67 M <- -0.267 cuM <- lns2ewma.crit(lambda, 200, df, cl=M, hs=M, r=60)[2] arls1 <- round(lns2ewma.ARL(lambda, 0, cu, sigmas, df, hs=0, sided="upper"), digits=2) arls2 <- round(lns2ewma.ARL(lambda, M, cuM, sigmas, df, hs=M, sided="upper", r=60), digits=2) data.frame(sigmas, arls1, arls2) } \keyword{ts} spc/man/xcusum.ad.Rd0000644000175100001440000000535512272513607014043 0ustar hornikusers\name{xcusum.ad} \alias{xcusum.ad} \title{Compute steady-state ARLs of CUSUM control charts} \description{Computation of the steady-state Average Run Length (ARL) for different types of CUSUM control charts monitoring normal mean.} \usage{xcusum.ad(k, h, mu1, mu0 = 0, sided = "one", r = 30)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.} \item{mu1}{out-of-control mean.} \item{mu0}{in-control mean.} \item{sided}{distinguish between one-, two-sided and Crosier's modified two-sided CUSUM scheme by choosing \code{"one"}, \code{"two"}, and \code{"Crosier"}, respectively.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-, two-sided) or \code{2r+1} (Crosier).} } \details{ \code{xcusum.ad} determines the steady-state Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature and using the power method for deriving the largest in magnitude eigenvalue and the related left eigenfunction. } \value{Returns a single value which resembles the steady-state ARL.} \references{ R. B. Crosier (1986), A new two-sided cumulative quality control scheme, \emph{Technometrics 28}, 187-194. } \note{Be cautious in increasing the dimension parameter \code{r} for two-sided CUSUM schemes. The resulting matrix dimension is \code{r^2} times \code{r^2}. Thus, go beyond 30 only on fast machines. This is the only case, were the package routines are based on the Markov chain approach. Moreover, the two-sided CUSUM scheme needs a two-dimensional Markov chain.} \author{Sven Knoth} \seealso{ \code{xcusum.arl} for zero-state ARL computation and \code{xewma.ad} for the steady-state ARL of EWMA control charts. } \examples{ ## comparison of zero-state (= worst case ) and steady-state performance ## for one-sided CUSUM control charts k <- .5 h <- xcusum.crit(k,500) mu <- c(0,.5,1,1.5,2) arl <- sapply(mu,k=k,h=h,xcusum.arl) ad <- sapply(mu,k=k,h=h,xcusum.ad) round(cbind(mu,arl,ad),digits=2) ## Crosier (1986), Crosier's modified two-sided CUSUM ## He introduced the modification and evaluated it by means of ## Markov chain approximation k <- .5 h2 <- 4 hC <- 3.73 mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,4,5) ad2 <- sapply(mu,k=k,h=h2,sided="two",r=20,xcusum.ad) adC <- sapply(mu,k=k,h=hC,sided="Crosier",xcusum.ad) round(cbind(mu,ad2,adC),digits=2) ## results in the original paper are (in Table 5) ## 0.00 163. 164. ## 0.25 71.6 69.0 ## 0.50 25.2 24.3 ## 0.75 12.3 12.1 ## 1.00 7.68 7.69 ## 1.50 4.31 4.39 ## 2.00 3.03 3.12 ## 2.50 2.38 2.46 ## 3.00 2.00 2.07 ## 4.00 1.55 1.60 ## 5.00 1.22 1.29 } \keyword{ts} spc/man/sewma.sf.prerun.Rd0000644000175100001440000000507212273730420015160 0ustar hornikusers\name{sewma.sf.prerun} \alias{sewma.sf.prerun} \title{Compute the survival function of EWMA run length} \description{Computation of the survival function of the Run Length (RL) for EWMA control charts monitoring normal variance.} \usage{sewma.sf.prerun(n, l, cl, cu, sigma, df1, df2, hs=1, sided="upper", qm=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE)} \arguments{ \item{n}{calculate sf up to value \code{n}.} \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{cl}{lower control limit of the EWMA control chart.} \item{cu}{upper control limit of the EWMA control chart.} \item{sigma}{true standard deviation.} \item{df1}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{df2}{degrees of freedom of the pre-run variance estimator.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} \item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.} \item{truncate}{size of truncated tail.} \item{tail_approx}{Controls whether the geometric tail approximation is used (is faster) or not.} } \details{ The survival function P(L>n) and derived from it also the cdf P(L<=n) and the pmf P(L=n) illustrate the distribution of the EWMA run length. For large n the geometric tail could be exploited. That is, with reasonable large n the complete distribution is characterized. The algorithm is based on Waldmann's survival function iteration procedure and on results in Knoth (2007)... } \value{Returns a vector which resembles the survival function up to a certain point.} \references{ S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{sewma.sf} for the RL survival function of EWMA control charts w/o pre-run uncertainty. } \examples{ ## Knoth (2014?) } \keyword{ts} spc/man/xDcusum.arl.Rd0000644000175100001440000001144012615440230014321 0ustar hornikusers\name{xDcusum.arl} \alias{xDcusum.arl} \title{Compute ARLs of CUSUM control charts under drift} \description{Computation of the (zero-state and other) Average Run Length (ARL) under drift for one-sided CUSUM control charts monitoring normal mean.} \usage{xDcusum.arl(k, h, delta, hs = 0, sided = "one", mode = "Gan", m = NULL, q = 1, r = 30, with0 = FALSE)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.} \item{delta}{true drift parameter.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided CUSUM control chart by choosing \code{"one"} and \code{"two"}, respectively. Currentlly, the two-sided scheme is not implemented.} \item{mode}{decide whether Gan's or Knoth's approach is used. Use \code{"Gan"} and \code{"Knoth"}, respectively.} \item{m}{parameter used if \code{mode="Gan"}. \code{m} is design parameter of Gan's approach. If \code{m=NULL}, then \code{m} will increased until the resulting ARL does not change anymore.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\geq)}, will be determined. Note that mu0=0 is implicitely fixed. Deploy large \code{q} to mimic steady-state. It works only for \code{mode="Knoth"}.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} \item{with0}{defines whether the first observation used for the RL calculation follows already 1*delta or still 0*delta. With \code{q} additional flexibility is given.} } \details{ Based on Gan (1991) or Knoth (2003), the ARL is calculated for one-sided CUSUM control charts under drift. In case of Gan's framework, the usual ARL function with mu=m*delta is determined and recursively via m-1, m-2, ... 1 (or 0) the drift ARL determined. The framework of Knoth allows to calculate ARLs for varying parameters, such as control limits and distributional parameters. For details see the cited papers. Note that two-sided CUSUM charts under drift are difficult to treat. } \value{Returns a single value which resembles the ARL.} \references{ F. F. Gan (1992), CUSUM control charts under linear drift, \emph{Statistician 41}, 71-84. F. F. Gan (1996), Average Run Lengths for Cumulative Sum control chart under linear trend, \emph{Applied Statistics 45}, 505-512. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2012), More on Control Charting under Drift, in: \emph{Frontiers in Statistical Quality Control 10}, H.-J. Lenz, W. Schmid and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 53-68. C. Zou, Y. Liu and Z. Wang (2009), Comparisons of control schemes for monitoring the means of processes subject to drifts, \emph{Metrika 70}, 141-163. } \author{Sven Knoth} \seealso{ \code{xcusum.arl} and \code{xcusum.ad} for zero-state and steady-state ARL computation of CUSUM control charts for the classical step change model. } \examples{ ## Gan (1992) ## Table 1 ## original values are # deltas arl # 0.0001 475 # 0.0005 261 # 0.0010 187 # 0.0020 129 # 0.0050 76.3 # 0.0100 52.0 # 0.0200 35.2 # 0.0500 21.4 # 0.1000 15.0 # 0.5000 6.95 # 1.0000 5.16 # 3.0000 3.30 \dontrun{k <- .25 h <- 8 r <- 50 DxDcusum.arl <- Vectorize(xDcusum.arl, "delta") deltas <- c(0.0001, 0.0005, 0.001, 0.002, 0.005, 0.01, 0.02, 0.05, 0.1, 0.5, 1, 3) arl.like.Gan <- round(DxDcusum.arl(k, h, deltas, r=r, with0=TRUE), digits=2) arl.like.Knoth <- round(DxDcusum.arl(k, h, deltas, r=r, mode="Knoth", with0=TRUE), digits=2) data.frame(deltas, arl.like.Gan, arl.like.Knoth)} ## Zou et al. (2009) ## Table 1 ## original values are # delta arl1 arl2 arl3 # 0 ~ 1730 # 0.0005 345 412 470 # 0.001 231 275 317 # 0.005 86.6 98.6 112 # 0.01 56.9 61.8 69.3 # 0.05 22.6 21.6 22.7 # 0.1 15.4 14.7 14.2 # 0.5 6.60 5.54 5.17 # 1.0 4.63 3.80 3.45 # 2.0 3.17 2.67 2.32 # 3.0 2.79 2.04 1.96 # 4.0 2.10 1.98 1.74 \dontrun{ k1 <- 0.25 k2 <- 0.5 k3 <- 0.75 h1 <- 9.660 h2 <- 5.620 h3 <- 3.904 deltas <- c(0.0005, 0.001, 0.005, 0.01, 0.05, 0.1, 0.5, 1:4) arl1 <- c(round(xcusum.arl(k1, h1, 0, r=r), digits=2), round(DxDcusum.arl(k1, h1, deltas, r=r), digits=2)) arl2 <- c(round(xcusum.arl(k2, h2, 0), digits=2), round(DxDcusum.arl(k2, h2, deltas, r=r), digits=2)) arl3 <- c(round(xcusum.arl(k3, h3, 0, r=r), digits=2), round(DxDcusum.arl(k3, h3, deltas, r=r), digits=2)) data.frame(delta=c(0, deltas), arl1, arl2, arl3)} } \keyword{ts} spc/man/xgrsr.crit.Rd0000644000175100001440000000420112077526641014233 0ustar hornikusers\name{xgrsr.crit} \alias{xgrsr.crit} \title{Compute alarm thresholds for Shiryaev-Roberts schemes} \description{Computation of the alarm thresholds (alarm limits) for Shiryaev-Roberts schemes monitoring normal mean.} \usage{xgrsr.crit(k, L0, mu0 = 0, zr = 0, hs = NULL, sided = "one", MPT = FALSE, r = 30)} \arguments{ \item{k}{reference value of the Shiryaev-Roberts scheme.} \item{L0}{in-control ARL.} \item{mu0}{in-control mean.} \item{zr}{reflection border to enable the numerical algorithms used here.} \item{hs}{so-called headstart (enables fast initial response). If \code{hs=NULL}, then the classical headstart -Inf is used (corresponds to 0 for the non-log scheme).} \item{sided}{distinguishes between one- and two-sided schemes by choosing \code{"one"} and\code{"two"}, respectively. Currently only one-sided schemes are implemented.} \item{MPT}{switch between the old implementation (\code{FALSE}) and the new one (\code{TRUE}) that considers the completed likelihood ratio. MPT contains the initials of G. Moustakides, A. Polunchenko and A. Tartakovsky.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1}.} } \details{ \code{xgrsr.crit} determines the alarm threshold (alarm limit) for given in-control ARL \code{L0} by applying secant rule and using \code{xgrsr.arl()}. } \value{Returns a single value which resembles the alarm limit \code{g}.} \references{ G. Moustakides, A. Polunchenko, A. Tartakovsky (2009), Numerical comparison of CUSUM and Shiryaev-Roberts procedures for detecting changes in distributions, \emph{Communications in Statistics: Theory and Methods 38}, 3225-3239.r. } \author{Sven Knoth} \seealso{\code{xgrsr.arl} for zero-state ARL computation.} \examples{ ## Table 4 from Moustakides et al. (2009) ## original values are # gamma/L0 A/exp(g) # 50 28.02 # 100 56.04 # 500 280.19 # 1000 560.37 # 5000 2801.75 # 10000 5603.7 theta <- 1 zr <- -6 r <- 100 Lxgrsr.crit <- Vectorize("xgrsr.crit", "L0") L0s <- c(50, 100, 500, 1000, 5000, 10000) gs <- Lxgrsr.crit(theta/2, L0s, zr=zr, r=r) data.frame(L0s, gs, A=round(exp(gs), digits=2)) } \keyword{ts} spc/man/quadrature.nodes.weights.Rd0000644000175100001440000000234712274005024017056 0ustar hornikusers\name{quadrature.nodes.weights} \alias{quadrature.nodes.weights} \title{Calculate quadrature nodes and weights} \description{Computation of the nodes and weights to enable numerical quadrature.} \usage{quadrature.nodes.weights(n, type="GL", x1=-1, x2=1)} \arguments{ \item{n}{number of nodes (and weights).} \item{type}{quadrature type -- currently Gauss-Legendre, \code{"GL"}, and Radau, \code{"Ra"}, are supported.} \item{x1}{lower limit of the integration interval.} \item{x2}{upper limit of the integration interval.} } \details{ A more detailed description will follow soon. The algorithm for the Gauss-Legendre quadrature was delivered by Knut Petras to me, while the one for the Radau quadrature was taken from John Burkardt. } \value{Returns two vectors which hold the needed quadrature nodes and weights.} \references{ H. Brass and K. Petras (2011), \emph{Quadrature Theory. The Theory of Numerical Integration on a Compact Interval,} Mathematical Surveys and Monographs, American Mathematical Society. } \author{Sven Knoth} \seealso{ Many of the ARL routines use the Gauss-Legendre nodes. } \examples{ # GL n <- 10 qnw <-quadrature.nodes.weights(n, type="GL") qnw # Radau n <- 10 qnw <-quadrature.nodes.weights(n, type="Ra") qnw } \keyword{ts} spc/man/sewma.crit.prerun.Rd0000644000175100001440000000763012274011725015514 0ustar hornikusers\name{sewma.crit.prerun} \alias{sewma.crit.prerun} \title{Compute critical values of of EWMA (variance charts) control charts under pre-run uncertainty} \description{Computation of quantiles of the Run Length (RL) for EWMA control charts monitoring normal variance.} \usage{sewma.crit.prerun(l,L0,df1,df2,sigma0=1,cl=NULL,cu=NULL,hs=1,sided="upper", mode="fixed",r=40,qm=30,qm.sigma=30,truncate=1e-10, tail_approx=TRUE,c.error=1e-10,a.error=1e-9)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{L0}{in-control quantile value.} \item{df1}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{df2}{degrees of freedom of the pre-run variance estimator.} \item{sigma,sigma0}{true and in-control standard deviation, respectively.} \item{cl}{deployed for \code{sided}=\code{"Rupper"}, that is, upper variance control chart with lower reflecting barrier \code{cl}.} \item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit (\code{mode}=\code{"fixed"}) a value larger than \code{sigma0} has to been given, for all other cases \code{cu} is ignored.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}),and \code{"two"} (two-sided chart), respectively.} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit (see \code{cu}) is set and only the lower is calculated to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated).} \item{r}{dimension of the resulting linear equation system (highest order of the collocation polynomials).} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} \item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.} \item{truncate}{size of truncated tail.} \item{tail_approx}{controls whether the geometric tail approximation is used (is faster) or not.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{a.error}{error bound for the quantile level \code{alpha} during applying the secant rule.} } \details{ \code{sewma.crit.prerun} determines the critical values (similar to alarm limits) for given in-control ARL \code{L0} by applying secant rule and using \code{sewma.arl.prerun()}. In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"} a two-dimensional secant rule is applied that also ensures that the maximum of the ARL function for given standard deviation is attained at \code{sigma0}. See Knoth (2010) for some details of the algorithm involved. } \value{Returns the lower and upper control limit \code{cl} and \code{cu}.} \references{ H.-J. Mittag and D. Stemann and B. Tewes (1998), EWMA-Karten zur \"Uberwachung der Streuung von Qualit\"atsmerkmalen, \emph{Allgemeines Statistisches Archiv 82}, 327-338, S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2010), Control Charting Normal Variance -- Reflections, Curiosities, and Recommendations, in \emph{Frontiers in Statistical Quality Control 9}, H.-J. Lenz and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 3-18. } \author{Sven Knoth} \seealso{\code{sewma.arl.prerun} for calculation of ARL of variance charts under pre-run uncertainty and \code{sewma.crit} for the algorithm w/o pre-run uncertainty.} \examples{ ## Knoth (2014?) } \keyword{ts}spc/man/xcusum.sf.Rd0000644000175100001440000000331512044563377014067 0ustar hornikusers\name{xcusum.sf} \alias{xcusum.sf} \title{Compute the survival function of CUSUM run length} \description{Computation of the survival function of the Run Length (RL) for CUSUM control charts monitoring normal mean.} \usage{xcusum.sf(k, h, mu, n, hs=0, sided="one", r=40)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.} \item{mu}{true mean.} \item{n}{calculate sf up to value \code{n}.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided CUSUM control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1}.} } \details{ The survival function P(L>n) and derived from it also the cdf P(L<=n) and the pmf P(L=n) illustrate the distribution of the CUSUM run length. For large n the geometric tail could be exploited. That is, with reasonable large n the complete distribution is characterized. The algorithm is based on Waldmann's survival function iteration procedure. } \value{Returns a vector which resembles the survival function up to a certain point.} \references{ K.-H. Waldmann (1986), Bounds for the distribution of the run length of one-sided and two-sided CUSUM quality control schemes, \emph{Technometrics 28}, 61-67. } \author{Sven Knoth} \seealso{ \code{xcusum.q} for computation of CUSUM run length quantiles. } \examples{ ## Waldmann (1986), one-sided CUSUM, Table 2 k <- .5 h <- 3 mu <- 0 # corresponds to Waldmann's -0.5 SF <- xcusum.sf(k, h, 0, 1000) plot(1:length(SF), SF, type="l", xlab="n", ylab="P(L>n)", ylim=c(0,1)) # } \keyword{ts} spc/man/xtewma.q.Rd0000644000175100001440000000605012524415065013670 0ustar hornikusers\name{xtewma.q} \alias{xtewma.q} \alias{xtewma.q.crit} \title{Compute RL quantiles of EWMA control charts} \description{Computation of quantiles of the Run Length (RL) for EWMA control charts monitoring normal mean.} \usage{xtewma.q(l, c, df, mu, alpha, zr=0, hs=0, sided="two", limits="fix", mode="tan", q=1, r=40) xtewma.q.crit(l, L0, df, mu, alpha, zr=0, hs=0, sided="two", limits="fix", mode="tan", r=40, c.error=1e-12, a.error=1e-9, OUTPUT=FALSE)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{df}{degrees of freedom -- parameter of the t distribution.} \item{mu}{true mean.} \item{alpha}{quantile level.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different control limits behavior.} \item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently, \code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\geq)}, will be determined. Note that mu0=0 is implicitely fixed.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} \item{L0}{in-control quantile value.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{a.error}{error bound for the quantile level \code{alpha} during applying the secant rule.} \item{OUTPUT}{activate or deactivate additional output.} } \details{ Instead of the popular ARL (Average Run Length) quantiles of the EWMA stopping time (Run Length) are determined. The algorithm is based on Waldmann's survival function iteration procedure. If \code{limits} is \code{"vacl"}, then the method presented in Knoth (2003) is utilized. For details see Knoth (2004). } \value{Returns a single value which resembles the RL quantile of order \code{q}.} \references{ F. F. Gan (1993), An optimal design of EWMA control charts based on the median run length, \emph{J. Stat. Comput. Simulation 45}, 169-184. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{xewma.q} for RL quantile computation of EWMA control charts in the normal case. } \examples{ ## will follow } \keyword{ts} spc/man/xewma.ad.Rd0000644000175100001440000000600112273730575013633 0ustar hornikusers\name{xewma.ad} \alias{xewma.ad} \title{Compute steady-state ARLs of EWMA control charts} \description{Computation of the steady-state Average Run Length (ARL) for different types of EWMA control charts monitoring normal mean.} \usage{xewma.ad(l, c, mu1, mu0=0, zr=0, z0=0, sided="one", limits="fix", steady.state.mode="conditional", r=40)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{mu1}{in-control mean.} \item{mu0}{out-of-control mean.} \item{zr}{reflection border for the one-sided chart.} \item{z0}{restarting value of the EWMA sequence in case of a false alarm in \code{steady.state.mode="cyclical"}.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different control limits behavior.} \item{steady.state.mode}{distinguishes between two steady-state modes -- conditional and cyclical.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} } \details{ \code{xewma.ad} determines the steady-state Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature and using the power method for deriving the largest in magnitude eigenvalue and the related left eigenfunction. } \value{Returns a single value which resembles the steady-state ARL.} \references{ R. B. Crosier (1986), A new two-sided cumulative quality control scheme, \emph{Technometrics 28}, 187-194. S. V. Crowder (1987), A simple method for studying run-length distributions of exponentially weighted moving average charts, \emph{Technometrics 29}, 401-407. J. M. Lucas and M. S. Saccucci (1990), Exponentially weighted moving average control schemes: Properties and enhancements, \emph{Technometrics 32}, 1-12. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL computation and \code{xcusum.ad} for the steady-state ARL of CUSUM control charts. } \examples{ ## comparison of zero-state (= worst case ) and steady-state performance ## for two-sided EWMA control charts l <- .1 c <- xewma.crit(l,500,sided="two") mu <- c(0,.5,1,1.5,2) arl <- sapply(mu,l=l,c=c,sided="two",xewma.arl) ad <- sapply(mu,l=l,c=c,sided="two",xewma.ad) round(cbind(mu,arl,ad),digits=2) ## Lucas/Saccucci (1990) ## two-sided EWMA ## with fixed limits l1 <- .5 l2 <- .03 c1 <- 3.071 c2 <- 2.437 mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,3.5,4,5) ad1 <- sapply(mu,l=l1,c=c1,sided="two",xewma.ad) ad2 <- sapply(mu,l=l2,c=c2,sided="two",xewma.ad) round(cbind(mu,ad1,ad2),digits=2) ## original results are (in Table 3) ## 0.00 499. 480. ## 0.25 254. 74.1 ## 0.50 88.4 28.6 ## 0.75 35.7 17.3 ## 1.00 17.3 12.5 ## 1.50 6.44 8.00 ## 2.00 3.58 5.95 ## 2.50 2.47 4.78 ## 3.00 1.91 4.02 ## 3.50 1.58 3.49 ## 4.00 1.36 3.09 ## 5.00 1.10 2.55 } \keyword{ts} spc/man/mewma.arl.Rd0000644000175100001440000001504412543257176014022 0ustar hornikusers\name{mewma.arl} \alias{mewma.arl} \alias{mewma.arl.f} \alias{mewma.ad} \title{Compute ARLs of MEWMA control charts} \description{Computation of the (zero-state) Average Run Length (ARL) for multivariate exponentially weighted moving average (MEWMA) charts monitoring multivariate normal mean.} \usage{mewma.arl(l, cE, p, delta=0, hs=0, r=20, ntype=NULL, qm0=20, qm1=qm0) mewma.arl.f(l, cE, p, delta=0, r=20, ntype=NULL, qm0=20, qm1=qm0) mewma.ad(l, cE, p, delta=0, r=20, n=20, type="cond", hs=0, ntype=NULL, qm0=20, qm1=qm0)} \arguments{ \item{l}{smoothing parameter lambda of the MEWMA control chart.} \item{cE}{alarm threshold of the MEWMA control chart.} \item{p}{dimension of multivariate normal distribution.} \item{delta}{magnitude of the potential change, \code{delta=0} refers to the in-control state.} \item{hs}{so-called headstart (enables fast initial response) -- must be non-negative.} \item{r}{number of quadrature nodes -- dimension of the resulting linear equation system for \code{delta} = 0. For non-zero \code{delta} this dimension is mostly r^2 (Markov chain approximation leads to some larger values). Caution: If \code{ntype} is set to \code{"co"} (collocation), then values of \code{r} larger than 20 lead to large computing times. For the other selections this would happen for values larger than 40.} \item{ntype}{choose the numerical algorithm to solve the ARL integral equation. For \code{delta}=0: Possible values are \code{"gl"}, \code{"gl2"} (gauss-legendre, classic and with variables change: square), \code{"co"} (collocation, for \code{delta} > 0 with sin transformation), \code{"ra"} (radau), \code{"cc"} (clenshaw-curtis), \code{"mc"} (markov chain), and \code{"sr"} (simpson rule). For \code{delta} larger than 0, some more values besides the others are possible: \code{"gl3"}, \code{"gl4"}, \code{"gl5"} (gauss-legendre with a further change in variables: sin, tan, sinh), \code{"co2"}, \code{"co3"} (collocation with some trimming and tan as quadrature stabilizing transformations, respectively). If it is set to \code{NULL} (the default), then for \code{delta}=0 then \code{"gl2"} is chosen. If \code{delta} larger than 0, then for \code{p} equal 2 or 4 \code{"gl3"} and for all other values \code{"gl5"} is taken. \code{"ra"} denotes the method used in Rigdon (1995a). \code{"mc"} denotes the Markov chain approximation.} \item{type}{switch between \code{"cond"} and \code{"cycl"} for differentiating between the conditional (no false alarm) and the cyclical (after false alarm re-start in \code{hs}), respectively.} \item{n}{number of quadrature nodes for Calculating the steady-state ARL integral(s).} \item{qm0,qm1}{number of collocation quadrature nodes for the out-of-control case (\code{qm0} for the inner integral, \code{qm1} for the outer one), that is, for positive \code{delta}, and for the in-control case (now only \code{qm0} is deployed) if via \code{ntype} the collocation procedure is requested.} } \details{Basically, this is the implementation of different numerical algorithms for solving the integral equation for the MEWMA in-control (\code{delta} = 0) ARL introduced in Rigdon (1995a) and out-of-control (\code{delta} != 0) ARL in Rigdon (1995b). Most of them are nothing else than the Nystroem approach -- the integral is replaced by a suitable quadrature. Here, the Gauss-Legendre (more powerful), Radau (used by Rigdon, 1995a), Clenshaw-Curtis, and Simpson rule (which is really bad) are provided. Additionally, the collocation approach is offered as well, because it is much better for small odd values for \code{p}. FORTRAN code for the Radau quadrature based Nystroem of Rigdon (1995a) was published in Bodden and Rigdon (1999) -- see also \url{http://lib.stat.cmu.edu/jqt/31-1}. Furthermore, FORTRAN code for the Markov chain approximation (in- and out-ot-control) could be found at \url{http://lib.stat.cmu.edu/jqt/33-4}. The related papers are Runger and Prabhu (1996) and Molnau et al. (2001). The idea of the Clenshaw-Curtis quadrature was taken from Capizzi and Masarotto (2010), who successfully deployed a modified Clenshaw-Curtis quadrature to calculate the ARL of combined (univariate) Shewhart-EWMA charts. It turns out that it works also nicely for the MEWMA ARL. The version \code{mewma.arl.f()} without the argument \code{hs} provides the ARL as function of one (in-control) or two (out-of-control) arguments. } \value{Returns a single value which is simply the zero-state ARL.} \references{ Kevin M. Bodden and Steven E. Rigdon (1999), A program for approximating the in-control ARL for the MEWMA chart, \emph{Journal of Quality Technology 31}, 120-123. Giovanna Capizzi and Guido Masarotto (2010), Evaluation of the run-length distribution for a combined Shewhart-EWMA control chart, \emph{Statistics and Computing 20}, 23-33. Wade E. Molnau et al. (2001), A Program for ARL Calculation for Multivariate EWMA Charts, \emph{Journal of Quality Technology 33}, 515-521. Steven E. Rigdon (1995a), An integral equation for the in-control average run length of a multivariate exponentially weighted moving average control chart, \emph{J. Stat. Comput. Simulation 52}, 351-365. Steven E. Rigdon (1995b), A double-integral equation for the average run length of a multivariate exponentially weighted moving average control chart, \emph{Stat. Probab. Lett. 24}, 365-373. George C. Runger and Sharad S. Prabhu (1996), A Markov Chain Model for the Multivariate Exponentially Weighted Moving Averages Control Chart, \emph{J. Amer. Statist. Assoc. 91}, 1701-1706. } \author{Sven Knoth} \seealso{ \code{mewma.crit} for getting the alarm threshold to attain a certain in-control ARL. } \examples{ # Rigdon (1995b), p. 372, Tab. 1 r <- 0.1 p <- 4 h <- 12.73 L0a <- mewma.arl(r, h, p) # defaults to "gl2" because of the even p. L0b <- mewma.arl(r, h, p, ntype="co") L0c <- mewma.arl(r, h, p, r=48, ntype="ra") L0d <- mewma.arl(r, h, p, ntype="cc") L0e <- mewma.arl(r, h, p, ntype="mc") data.frame(L0a, L0b, L0c, L0d, L0e) # original (Rigdon 1995a) implicite value is 200 p <- 3 h <- 14.98 L0a <- mewma.arl(r, h, p, ntype="gl2") L0aa <- mewma.arl(r, h, p, r=48, ntype="gl2") L0b <- mewma.arl(r, h, p, ntype="co") L0bb <- mewma.arl(r, h, p, r=48, ntype="co") L0c <- mewma.arl(r, h, p, r=48, ntype="ra") L0d <- mewma.arl(r, h, p, ntype="cc") L0dd <- mewma.arl(r, h, p, r=48, ntype="cc") L0e <- mewma.arl(r, h, p, ntype="mc") L0ee <- mewma.arl(r, h, p, r=48, ntype="mc") data.frame(L0a, L0aa, L0b, L0bb, L0c, L0d, L0dd, L0e, L0ee) # original (Rigdon 1995a) implicite value is 1000 # Rigdon (1995b), p. 372, Tab. 1 p <- 5 h <- 14.56 L1 <- mewma.arl(r, h, p, delta=1, r=20) L1 # original value is 12.9 } \keyword{ts} spc/man/xewma.q.Rd0000644000175100001440000000775512273731014013515 0ustar hornikusers\name{xewma.q} \alias{xewma.q} \alias{xewma.q.crit} \title{Compute RL quantiles of EWMA control charts} \description{Computation of quantiles of the Run Length (RL) for EWMA control charts monitoring normal mean.} \usage{xewma.q(l, c, mu, alpha, zr=0, hs=0, sided="two", limits="fix", q=1, r=40) xewma.q.crit(l, L0, mu, alpha, zr=0, hs=0, sided="two", limits="fix", r=40, c.error=1e-12, a.error=1e-9, OUTPUT=FALSE)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{mu}{true mean.} \item{alpha}{quantile level.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different control limits behavior.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\geq)}, will be determined. Note that mu0=0 is implicitely fixed.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} \item{L0}{in-control quantile value.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{a.error}{error bound for the quantile level \code{alpha} during applying the secant rule.} \item{OUTPUT}{activate or deactivate additional output.} } \details{ Instead of the popular ARL (Average Run Length) quantiles of the EWMA stopping time (Run Length) are determined. The algorithm is based on Waldmann's survival function iteration procedure. If \code{limits} is not \code{"fix"}, then the method presented in Knoth (2003) is utilized. Note that for one-sided EWMA charts (\code{sided}=\code{"one"}), only \code{"vacl"} and \code{"stat"} are deployed, while for two-sided ones (\code{sided}=\code{"two"}) also \code{"fir"}, \code{"both"} (combination of \code{"fir"} and \code{"vacl"}), and \code{"Steiner"} are implemented. For details see Knoth (2004). } \value{Returns a single value which resembles the RL quantile of order \code{q}.} \references{ F. F. Gan (1993), An optimal design of EWMA control charts based on the median run length, \emph{J. Stat. Comput. Simulation 45}, 169-184. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL computation of EWMA control charts. } \examples{ ## Gan (1993), two-sided EWMA with fixed control limits ## some values of his Table 1 -- any median RL should be 500 XEWMA.Q <- Vectorize("xewma.q", c("l", "c")) G.lambda <- c(.05, .1, .15, .2, .25) G.h <- c(.441, .675, .863, 1.027, 1.177) MEDIAN <- ceiling(XEWMA.Q(G.lambda, G.h/sqrt(G.lambda/(2-G.lambda)), 0, .5, sided="two")) print(cbind(G.lambda, MEDIAN)) ## increase accuracy of thresholds # (i) calculate threshold for given in-control median value by # deplyoing secant rule XEWMA.q.crit <- Vectorize("xewma.q.crit", "l") # (ii) re-calculate the thresholds and remove the standardization step L0 <- 500 G.h.new <- XEWMA.q.crit(G.lambda, L0, 0, .5, sided="two") G.h.new <- round(G.h.new * sqrt(G.lambda/(2-G.lambda)), digits=5) # (iii) compare Gan's original values and the new ones with 5 digits print(cbind(G.lambda, G.h.new, G.h)) # (iv) calculate the new medians MEDIAN <- ceiling(XEWMA.Q(G.lambda, G.h.new/sqrt(G.lambda/(2-G.lambda)), 0, .5, sided="two")) print(cbind(G.lambda, MEDIAN)) } \keyword{ts} spc/man/sewma.q.prerun.Rd0000644000175100001440000001003712273730154015011 0ustar hornikusers\name{sewma.q.prerun} \alias{sewma.q.prerun} \alias{sewma.q.crit.prerun} \title{Compute RL quantiles of EWMA (variance charts) control charts under pre-run uncertainty} \description{Computation of quantiles of the Run Length (RL) for EWMA control charts monitoring normal variance.} \usage{sewma.q.prerun(l,cl,cu,sigma,df1,df2,alpha,hs=1,sided="upper", r=40,qm=30,qm.sigma=30,truncate=1e-10) sewma.q.crit.prerun(l,L0,alpha,df1,df2,sigma0=1,cl=NULL,cu=NULL,hs=1, sided="upper",mode="fixed",r=40, qm=30,qm.sigma=30,truncate=1e-10, tail_approx=TRUE,c.error=1e-10,a.error=1e-9)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{cl}{deployed for \code{sided}=\code{"Rupper"}, that is, upper variance control chart with lower reflecting barrier \code{cl}.} \item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit (\code{mode}=\code{"fixed"}) a value larger than \code{sigma0} has to been given, for all other cases \code{cu} is ignored.} \item{sigma,sigma0}{true and in-control standard deviation, respectively.} \item{L0}{in-control quantile value.} \item{alpha}{quantile level.} \item{df1}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{df2}{degrees of freedom of the pre-run variance estimator.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit (see \code{cu}) is set and only the lower is calculated to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated).} \item{r}{dimension of the resulting linear equation system (highest order of the collocation polynomials).} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} \item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.} \item{truncate}{size of truncated tail.} \item{tail_approx}{controls whether the geometric tail approximation is used (is faster) or not.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{a.error}{error bound for the quantile level \code{alpha} during applying the secant rule.} } \details{ Instead of the popular ARL (Average Run Length) quantiles of the EWMA stopping time (Run Length) are determined. The algorithm is based on Waldmann's survival function iteration procedure. Thereby the ideas presented in Knoth (2007) are used. \code{sewma.q.crit.prerun} determines the critical values (similar to alarm limits) for given in-control RL quantile \code{L0} at level \code{alpha} by applying secant rule and using \code{sewma.sf()}. In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"} a two-dimensional secant rule is applied that also ensures that the minimum of the cdf for given standard deviation is attained at \code{sigma0}. } \value{Returns a single value which resembles the RL quantile of order \code{alpha} and the lower and upper control limit \code{cl} and \code{cu}, respectively.} \references{ S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{\code{sewma.q} and \code{sewma.q.crit} for the version w/o pre-run uncertainty.} \examples{ ## Knoth (2014?) } \keyword{ts} spc/man/sewma.q.Rd0000644000175100001440000001062112273730327013500 0ustar hornikusers\name{sewma.q} \alias{sewma.q} \alias{sewma.q.crit} \title{Compute RL quantiles of EWMA (variance charts) control charts} \description{Computation of quantiles of the Run Length (RL) for EWMA control charts monitoring normal variance.} \usage{sewma.q(l, cl, cu, sigma, df, alpha, hs=1, sided="upper", r=40, qm=30) sewma.q.crit(l,L0,alpha,df,sigma0=1,cl=NULL,cu=NULL,hs=1,sided="upper", mode="fixed",ur=4,r=40,qm=30,c.error=1e-12,a.error=1e-9)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{cl}{deployed for \code{sided}=\code{"Rupper"}, that is, upper variance control chart with lower reflecting barrier \code{cl}.} \item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit (\code{mode}=\code{"fixed"}) a value larger than \code{sigma0} has to been given, for all other cases \code{cu} is ignored.} \item{sigma,sigma0}{true and in-control standard deviation, respectively.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{alpha}{quantile level.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}),and \code{"two"} (two-sided chart), respectively.} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit (see \code{cu}) is set and only the lower is calculated to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated).} \item{ur}{truncation of lower chart for \code{classic} mode.} \item{r}{dimension of the resulting linear equation system (highest order of the collocation polynomials).} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} \item{L0}{in-control quantile value.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{a.error}{error bound for the quantile level \code{alpha} during applying the secant rule.} } \details{ Instead of the popular ARL (Average Run Length) quantiles of the EWMA stopping time (Run Length) are determined. The algorithm is based on Waldmann's survival function iteration procedure. Thereby the ideas presented in Knoth (2007) are used. \code{sewma.q.crit} determines the critical values (similar to alarm limits) for given in-control RL quantile \code{L0} at level \code{alpha} by applying secant rule and using \code{sewma.sf()}. In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"} a two-dimensional secant rule is applied that also ensures that the minimum of the cdf for given standard deviation is attained at \code{sigma0}. } \value{Returns a single value which resembles the RL quantile of order \code{alpha} and the lower and upper control limit \code{cl} and \code{cu}, respectively.} \references{ H.-J. Mittag and D. Stemann and B. Tewes (1998), EWMA-Karten zur \"Uberwachung der Streuung von Qualit\"atsmerkmalen, \emph{Allgemeines Statistisches Archiv 82}, 327-338, C. A. Acosta-Mej\'ia and J. J. Pignatiello Jr. and B. V. Rao (1999), A comparison of control charting procedures for monitoring process dispersion, \emph{IIE Transactions 31}, 569-579. S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. S. Knoth (2010), Control Charting Normal Variance -- Reflections, Curiosities, and Recommendations, in \emph{Frontiers in Statistical Quality Control 9}, H.-J. Lenz and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 3-18. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{\code{sewma.arl} for calculation of ARL of variance charts and \code{sewma.sf} for the RL survival function.} \examples{ ## Knoth (2014?) } \keyword{ts} spc/man/xcusum.q.Rd0000644000175100001440000000314712050203722013700 0ustar hornikusers\name{xcusum.q} \alias{xcusum.q} \title{Compute RL quantiles of CUSUM control charts} \description{Computation of quantiles of the Run Length (RL)for CUSUM control charts monitoring normal mean.} \usage{xcusum.q(k, h, mu, alpha, hs=0, sided="one", r=40)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.} \item{mu}{true mean.} \item{alpha}{quantile level.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided CUSUM control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1}.} } \details{ Instead of the popular ARL (Average Run Length) quantiles of the CUSUM stopping time (Run Length) are determined. The algorithm is based on Waldmann's survival function iteration procedure. } \value{Returns a single value which resembles the RL quantile of order \code{q}.} \references{ K.-H. Waldmann (1986), Bounds for the distribution of the run length of one-sided and two-sided CUSUM quality control schemes, \emph{Technometrics 28}, 61-67. } \author{Sven Knoth} \seealso{ \code{xcusum.arl} for zero-state ARL computation of CUSUM control charts. } \examples{ ## Waldmann (1986), one-sided CUSUM, Table 2 ## original values are 345, 82, 9 XCUSUM.Q <- Vectorize("xcusum.q", "alpha") k <- .5 h <- 3 mu <- 0 # corresponds to Waldmann's -0.5 a.list <- c(.95, .5, .05) rl.quantiles <- ceiling(XCUSUM.Q(k, h, mu, a.list)) cbind(a.list, rl.quantiles) } \keyword{ts} spc/man/xshewhartrunsrules.arl.Rd0000644000175100001440000001277412044565571016720 0ustar hornikusers\name{xshewhartrunsrules.arl} \alias{xshewhartrunsrules.arl} \alias{xshewhartrunsrules.crit} \alias{xshewhartrunsrules.ad} \alias{xshewhartrunsrules.matrix} \title{Compute ARLs of Shewhart control charts with and without runs rules} \description{Computation of the (zero-state and steady-state) Average Run Length (ARL) for Shewhart control charts with and without runs rules monitoring normal mean.} \usage{xshewhartrunsrules.arl(mu, c = 1, type = "12") xshewhartrunsrules.crit(L0, mu = 0, type = "12") xshewhartrunsrules.ad(mu1, mu0 = 0, c = 1, type = "12") xshewhartrunsrules.matrix(mu, c = 1, type = "12")} \arguments{ \item{mu}{true mean.} \item{L0}{pre-defined in-control ARL, that is, determine \code{c} so that the mean number of observations until a false alarm is \code{L0}.} \item{mu1, mu0}{for the steady-state ARL two means are specified, mu0 is the in-control one and usually equal to 0 , and mu1 must be given.} \item{c}{normalizing constant to ensure specific alarming behavior.} \item{type}{controls the type of Shewhart chart used, seed details section.} } \details{ \code{xshewhartrunsrules.arl} determines the zero-state Average Run Length (ARL) based on the Markov chain approach given in Champ and Woodall (1987). \code{xshewhartrunsrules.matrix} provides the corresponding transition matrix that is also used in \code{xDshewhartrunsrules.arl} (ARL for control charting drift). \code{xshewhartrunsrules.crit} allows to find the normalization constant \code{c} to attain a fixed in-control ARL. Typically this is needed to calibrate the chart. With \code{xshewhartrunsrules.ad} the steady-state ARL is calculated. With the argument \code{type} certain runs rules could be set. The following list gives an overview. \itemize{ \item{"1"}{ The classical Shewhart chart with \code{+/- 3 c sigma} control limits (\code{c} is typically equal to 1 and can be changed by the argument \code{c}).} \item{"12"}{ The classic and the following runs rule: 2 of 3 are beyond \code{+/- 2 c sigma} on the same side of the chart.} \item{"13"}{ The classic and the following runs rule: 4 of 5 are beyond \code{+/- 1 c sigma} on the same side of the chart.} \item{"14"}{ The classic and the following runs rule: 8 of 8 are on the same side of the chart (referring to the center line).}} } \value{Returns a single value which resembles the zero-state or steady-state ARL. \code{xshewhartrunsrules.matrix} returns a matrix.} \references{ C. W. Champ and W. H. Woodall (1987), Exact results for Shewhart control charts with supplementary runs rules, \emph{Technometrics 29}, 393-399. } \author{Sven Knoth} \seealso{ \code{xDshewhartrunsrules.arl} for zero-state ARL of Shewhart control charts with or without runs rules under drift. } \examples{ ## Champ/Woodall (1987) ## Table 1 mus <- (0:15)/5 Mxshewhartrunsrules.arl <- Vectorize(xshewhartrunsrules.arl, "mu") # standard (1 of 1 beyond 3 sigma) Shewhart chart without runs rules C1 <- round(Mxshewhartrunsrules.arl(mus, type="1"), digits=2) # standard + runs rule: 2 of 3 beyond 2 sigma on the same side C12 <- round(Mxshewhartrunsrules.arl(mus, type="12"), digits=2) # standard + runs rule: 4 of 5 beyond 1 sigma on the same side C13 <- round(Mxshewhartrunsrules.arl(mus, type="13"), digits=2) # standard + runs rule: 8 of 8 on the same side of the center line C14 <- round(Mxshewhartrunsrules.arl(mus, type="14"), digits=2) ## original results are # mus C1 C12 C13 C14 # 0.0 370.40 225.44 166.05 152.73 # 0.2 308.43 177.56 120.70 110.52 # 0.4 200.08 104.46 63.88 59.76 # 0.6 119.67 57.92 33.99 33.64 # 0.8 71.55 33.12 19.78 21.07 # 1.0 43.89 20.01 12.66 14.58 # 1.2 27.82 12.81 8.84 10.90 # 1.4 18.25 8.69 6.62 8.60 # 1.6 12.38 6.21 5.24 7.03 # 1.8 8.69 4.66 4.33 5.85 # 2.0 6.30 3.65 3.68 4.89 # 2.2 4.72 2.96 3.18 4.08 # 2.4 3.65 2.48 2.78 3.38 # 2.6 2.90 2.13 2.43 2.81 # 2.8 2.38 1.87 2.14 2.35 # 3.0 2.00 1.68 1.89 1.99 data.frame(mus, C1, C12, C13, C14) ## plus calibration, i. e. L0=250 (the maximal value for "14" is 255! L0 <- 250 c1 <- xshewhartrunsrules.crit(L0, type = "1") c12 <- xshewhartrunsrules.crit(L0, type = "12") c13 <- xshewhartrunsrules.crit(L0, type = "13") c14 <- xshewhartrunsrules.crit(L0, type = "14") C1 <- round(Mxshewhartrunsrules.arl(mus, c=c1, type="1"), digits=2) C12 <- round(Mxshewhartrunsrules.arl(mus, c=c12, type="12"), digits=2) C13 <- round(Mxshewhartrunsrules.arl(mus, c=c13, type="13"), digits=2) C14 <- round(Mxshewhartrunsrules.arl(mus, c=c14, type="14"), digits=2) data.frame(mus, C1, C12, C13, C14) ## and the steady-state ARL Mxshewhartrunsrules.ad <- Vectorize(xshewhartrunsrules.ad, "mu1") C1 <- round(Mxshewhartrunsrules.ad(mus, c=c1, type="1"), digits=2) C12 <- round(Mxshewhartrunsrules.ad(mus, c=c12, type="12"), digits=2) C13 <- round(Mxshewhartrunsrules.ad(mus, c=c13, type="13"), digits=2) C14 <- round(Mxshewhartrunsrules.ad(mus, c=c14, type="14"), digits=2) data.frame(mus, C1, C12, C13, C14) } \keyword{ts} spc/man/mewma.psi.Rd0000644000175100001440000000311012525643570014023 0ustar hornikusers\name{mewma.psi} \alias{mewma.psi} \title{Compute steady-state density of the MEWMA statistic} \description{Computation of the (zero-state) steady-state density function of the statistic deployed in multivariate exponentially weighted moving average (MEWMA) charts monitoring multivariate normal mean.} \usage{mewma.psi(l, cE, p, type="cond", hs=0, r=20)} \arguments{ \item{l}{smoothing parameter lambda of the MEWMA control chart.} \item{cE}{alarm threshold of the MEWMA control chart.} \item{p}{dimension of multivariate normal distribution.} \item{type}{switch between \code{"cond"} and \code{"cycl"} for differentiating between the conditional (no false alarm) and the cyclical (after false alarm re-start in \code{hs}), respectively.} \item{hs}{the re-starting point for the cyclical steady-state framework.} \item{r}{number of quadrature nodes.} } \details{Basically, ideas from Knoth (2015, MEWMA numerics) and Knoth (2014, steady-state ARL concepts) are merged. More details will follow.} \value{Returns a function.} \references{ Sven Knoth (2014), The Case Against the Use of Synthetic Control Charts, accepted in \emph{Journal of Quality Technology}. Sven Knoth (2015), ARL numerics for MEWMA charts, under revision in \emph{Journal of Quality Technology}. } \author{Sven Knoth} \seealso{ \code{mewma.arl} for calculating the in-control ARL of MEWMA. } \examples{ lambda <- 0.1 L0 <- 1000 p <- 3 h4 <- mewma.crit(lambda, L0, p) x_ <- seq(0, h4*lambda/(2-lambda), by=0.002) psi <- mewma.psi(lambda, h4, p) psi_ <- psi(x_) #plot(x_, psi_, type="l", xlab="x", ylab=expression(psi(x))) } \keyword{ts} spc/man/sewma.crit.Rd0000644000175100001440000001443212274012075014177 0ustar hornikusers\name{sewma.crit} \alias{sewma.crit} \title{Compute critical values of EWMA control charts (variance charts)} \description{Computation of the critical values (similar to alarm limits) for different types of EWMA control charts (based on the sample variance \eqn{S^2}) monitoring normal variance.} \usage{sewma.crit(l,L0,df,sigma0=1,cl=NULL,cu=NULL,hs=NULL,s2.on=TRUE, sided="upper",mode="fixed",ur=4,r=40,qm=30)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{L0}{in-control ARL.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{sigma0}{in-control standard deviation.} \item{cl}{deployed for \code{sided}=\code{"Rupper"}, that is, upper variance control chart with lower reflecting barrier \code{cl}.} \item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit (\code{mode}=\code{"fixed"}) a value larger than \code{sigma0} has to been given, for all other cases \code{cu} is ignored.} \item{hs}{so-called headstart (enables fast initial response); the default (\code{NULL}) yields the expected in-control value of \eqn{S^2}{S^2} (1) and \eqn{S}{S} (\eqn{c_4}{c_4}), respectively.} \item{s2.on}{distinguishes between \eqn{S^2}{S^2} and \eqn{S}{S} chart.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit (see \code{cu}) is set and only the lower is calculated to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated). With \code{"vanilla"} limits symmetric around 1 (the in-control value of the variance) are determined, while for \code{"eq.tails"} the in-control ARL values of two single EWMA variance charts (decompose the two-sided scheme into one lower and one upper scheme) are matched.} \item{ur}{truncation of lower chart for \code{eq.tails} mode.} \item{r}{dimension of the resulting linear equation system (highest order of the collocation polynomials).} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} } \details{ \code{sewma.crit} determines the critical values (similar to alarm limits) for given in-control ARL \code{L0} by applying secant rule and using \code{sewma.arl()}. In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"} a two-dimensional secant rule is applied that also ensures that the maximum of the ARL function for given standard deviation is attained at \code{sigma0}. See Knoth (2010) and the related example. } \value{Returns the lower and upper control limit \code{cl} and \code{cu}.} \references{ H.-J. Mittag and D. Stemann and B. Tewes (1998), EWMA-Karten zur \"Uberwachung der Streuung von Qualit\"atsmerkmalen, \emph{Allgemeines Statistisches Archiv 82}, 327-338, C. A. Acosta-Mej\'ia and J. J. Pignatiello Jr. and B. V. Rao (1999), A comparison of control charting procedures for monitoring process dispersion, \emph{IIE Transactions 31}, 569-579. S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2006a), Computation of the ARL for CUSUM-\eqn{S^2}{S^2} schemes, \emph{Computational Statistics & Data Analysis 51}, 499-512. S. Knoth (2006b), The art of evaluating monitoring schemes -- how to measure the performance of control charts? in \emph{Frontiers in Statistical Quality Control 8}, H.-J. Lenz and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 74-99. S. Knoth (2010), Control Charting Normal Variance -- Reflections, Curiosities, and Recommendations, in \emph{Frontiers in Statistical Quality Control 9}, H.-J. Lenz and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 3-18. } \author{Sven Knoth} \seealso{\code{sewma.arl} for calculation of ARL of variance charts.} \examples{ ## Mittag et al. (1998) ## compare their upper critical value 2.91 that ## leads to the upper control limit via the formula shown below ## (for the usual upper EWMA \eqn{S^2}{S^2}). ## See Knoth (2006b) for a discussion of this EWMA setup and it's evaluation. l <- 0.18 L0 <- 250 df <- 4 limits <- sewma.crit(l, L0, df) limits["cu"] limits.cu.mittag_et_al <- 1 + sqrt(l/(2-l))*sqrt(2/df)*2.91 limits.cu.mittag_et_al ## Knoth (2005) ## reproduce the critical value given in Figure 2 (c=1.661865) for ## upper EWMA \eqn{S^2}{S^2} with df=1 l <- 0.025 L0 <- 250 df <- 1 limits <- sewma.crit(l, L0, df) cv.Fig2 <- (limits["cu"]-1)/( sqrt(l/(2-l))*sqrt(2/df) ) cv.Fig2 ## the small difference (sixth digit after decimal point) stems from ## tighter criterion in the secant rule implemented in the R package. ## demo of unbiased ARL curves ## Deploy, please, not matrix dimensions smaller than 50 -- for the ## sake of accuracy, the value 80 was used. ## Additionally, this example needs between 1 and 2 minutes on a 1.6 Ghz box. \dontrun{ l <- 0.1 L0 <- 500 df <- 4 limits <- sewma.crit(l, L0, df, sided="two", mode="unbiased", r=80) SEWMA.arl <- Vectorize(sewma.arl, "sigma") SEWMA.ARL <- function(sigma) SEWMA.arl(l, limits[1], limits[2], sigma, df, sided="two", r=80) layout(matrix(1:2, nrow=1)) curve(SEWMA.ARL, .75, 1.25, log="y") curve(SEWMA.ARL, .95, 1.05, log="y")} # the above stuff needs about 1 minute ## control limits for upper and lower EWMA charts with reflecting barriers ## (reflection at in-control level sigma0 = 1) ## examples from Knoth (2006a), Tables 4 and 5 \dontrun{ ## upper chart with reflection at sigma0=1 in Table 4: c = 2.4831 l <- 0.15 L0 <- 100 df <- 4 limits <- sewma.crit(l, L0, df, cl=1, sided="Rupper", r=100) cv.Tab4 <- (limits["cu"]-1)/( sqrt(l/(2-l))*sqrt(2/df) ) cv.Tab4 ## lower chart with reflection at sigma0=1 in Table 5: c = 2.0613 l <- 0.115 L0 <- 200 df <- 5 limits <- sewma.crit(l, L0, df, cu=1, sided="Rlower", r=100) cv.Tab5 <- -(limits["cl"]-1)/( sqrt(l/(2-l))*sqrt(2/df) ) cv.Tab5} } \keyword{ts} spc/man/xshewhart.ar1.arl.Rd0000644000175100001440000000577412655133072015414 0ustar hornikusers\name{xshewhart.ar1.arl} \alias{xshewhart.ar1.arl} \title{Compute ARLs of modified Shewhart control charts for AR(1) data} \description{Computation of the (zero-state) Average Run Length (ARL) for modified Shewhart charts deploywed to the original AR(1) data.} \usage{xshewhart.ar1.arl(alpha, cS, delta=0, N1=50, N2=30)} \arguments{ \item{alpha}{lag 1 correlation of the data.} \item{cS}{critical value (alias to alarm limit) of the Shewhart control chart.} \item{delta}{potential shift in the data (in-control mean is zero.} \item{N1}{number of quadrature nodes for solving the ARL integral equation, dimension of the resulting linear equation system is \code{N1}.} \item{N2}{second number of quadrature nodes for combining the probability density function of the first observation following the margin distribution and the solution of the ARL integral equation}. } \details{ In case of the EWMA chart with fixed control limits, \code{xewma.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature. If \code{limits} is not \code{"fix"}, then the method presented in Knoth (2003) is utilized. Note that for one-sided EWMA charts (\code{sided}=\code{"one"}), only \code{"vacl"} and \code{"stat"} are deployed, while for two-sided ones (\code{sided}=\code{"two"}) also \code{"fir"}, \code{"both"} (combination of \code{"fir"} and \code{"vacl"}), and \code{"Steiner"} are implemented. For details see Knoth (2004). } \value{Following the idea of Schmid (1995), \code{1- alpha} times the data turns out to be an EWMA smoothing of the underlying AR(1) residuals. Hence, by combining the solution of the EWMA ARL integral equation and the stationary distribution of the AR(1) data (normal distribution is assumed) one gets easily the overall ARL.} \references{ S. Knoth, W. Schmid (2004). Control charts for time series: A review. In \emph{Frontiers in Statistical Quality Control 7}, edited by H.-J. Lenz, P.-T. Wilrich, 210-236, Physica-Verlag. H. Kramer, W. Schmid (2000). The influence of parameter estimation on the ARL of Shewhart type charts for time series. \emph{Statistical Papers 41}(2), 173-196. W. Schmid (1995). On the run length of a Shewhart chart for correlated data. \emph{Statistical Papers 36}(1), 111-130. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL computation of EWMA control charts. } \examples{ ## Table 1 in Kramer/Schmid (2000) cS <- 3.09023 a <- seq(0, 4, by=.5) row1 <- row2 <- row3 <- NULL for ( i in 1:length(a) ) { row1 <- c(row1, round(xshewhart.ar1.arl( 0.4, cS, delta=a[i]), digits=2)) row2 <- c(row2, round(xshewhart.ar1.arl( 0.2, cS, delta=a[i]), digits=2)) row3 <- c(row3, round(xshewhart.ar1.arl(-0.2, cS, delta=a[i]), digits=2)) } results <- rbind(row1, row2, row3) results # original values are # row1 515.44 215.48 61.85 21.63 9.19 4.58 2.61 1.71 1.29 # row2 502.56 204.97 56.72 19.13 7.95 3.97 2.33 1.59 1.25 # row3 502.56 201.41 54.05 17.42 6.89 3.37 2.03 1.46 1.20 } \keyword{ts} spc/man/phat.ewma.arl.Rd0000644000175100001440000001047412524415033014565 0ustar hornikusers\name{phat.ewma.arl} \alias{phat.ewma.arl} \alias{phat.ewma.crit} \alias{phat.ewma.lambda} \title{Compute ARLs of EWMA phat control charts} \description{Computation of the (zero-state) Average Run Length (ARL), upper control limit (ucl) for given in-control ARL, and lambda for minimal out-of control ARL at given shift.} \usage{phat.ewma.arl(lambda, ucl, mu, n, z0, sigma=1, type="known", LSL=-3, USL=3, N=15, qm=25, ntype="coll") phat.ewma.crit(lambda, L0, mu, n, z0, sigma=1, type="known", LSL=-3, USL=3, N=15, qm=25) phat.ewma.lambda(L0, mu, n, z0, sigma=1, type="known", max_l=1, min_l=.001, LSL=-3, USL=3, qm=25) } \arguments{ \item{lambda}{smoothing parameter of the EWMA control chart.} \item{ucl}{upper control limit of the EWMA phat control chart.} \item{L0}{pre-defined in-control ARL (Average Run Length).} \item{mu}{true mean or mean where the ARL should be minimized (then the in-control mean is simply 0).} \item{n}{subgroup size.} \item{z0}{so-called headstart (gives fast initial response).} \item{type}{choose whether the standard deviation is given and fixed (\code{"known"}) or estimated and potentially monitored (\code{"estimated"}).} \item{sigma}{actual standard deviation of the data -- the in-control value is 1.} \item{max_l, min_l}{maximal and minimal value for optimal lambda search.} \item{LSL,USL}{lower and upper specification limit, respectively.} \item{N}{size of collocation base, dimension of the resulting linear equation system is equal to \code{N}.} \item{qm}{number of nodes for collocation quadratures.} \item{ntype}{switch between the default method \code{coll} (collocation) and the classic one \code{markov} (Markov chain approximation) for calculating the ARL numerically.} } \details{ The three implemented functions allow to apply a new type control chart. Basically, lower and upper specification limits are given. The monitoring vehicle then is the empirical probability that an item will not follow these specification given the sequence of sample means. If the related EWMA sequence violates the control limits, then the alarm indicates a significant process deterioration. For details see the paper mentioned in the references. To be able to construct the control charts, see the first example. } \value{Return single values which resemble the ARL, the critical value, and the optimal lambda, respectively.} \references{ S. Knoth and S. Steinmetz (2013), EWMA \code{p} charts under sampling by variables, \emph{International Journal of Production Research} 51, 3795-3807. } \author{Sven Knoth} \seealso{ \code{sewma.arl} for a further collocation based ARL calculation routine.} \examples{ ## Simple example to demonstrate the chart. # some functions h.mu <- function(mu) pnorm(LSL-mu) + pnorm(mu-USL) ewma <- function(x, lambda=0.1, z0=0) filter(lambda*x, 1-lambda, m="r", init=z0) # parameters LSL <- -3 # lower specification limit USL <- 3 # upper specification limit n <- 5 # batch size lambda <- 0.1 # EWMA smoothing parameter L0 <- 1000 # in-control Average Run Length (ARL) z0 <- h.mu(0) # start at minimal defect level ucl <- phat.ewma.crit(lambda, L0, 0, n, z0, LSL=LSL, USL=USL) # data x0 <- matrix(rnorm(50*n), ncol=5) # in-control data x1 <- matrix(rnorm(50*n, mean=0.5), ncol=5)# out-of-control data x <- rbind(x0,x1) # all data # create chart xbar <- apply(x, 1, mean) phat <- h.mu(xbar) z <- ewma(phat, lambda=lambda, z0=z0) plot(1:length(z), z, type="l", xlab="batch", ylim=c(0,.02)) abline(h=z0, col="grey", lwd=.7) abline(h=ucl, col="red") ## S. Knoth, S. Steinmetz (2013) # Table 1 lambdas <- c(.5, .25, .2, .1) L0 <- 370.4 n <- 5 LSL <- -3 USL <- 3 phat.ewma.CRIT <- Vectorize("phat.ewma.crit", "lambda") p.star <- pnorm( LSL ) + pnorm( -USL ) ## lower bound of the chart ucls <- phat.ewma.CRIT(lambdas, L0, 0, n, p.star, LSL=LSL, USL=USL) print(cbind(lambdas, ucls)) # Table 2 mus <- c((0:4)/4, 1.5, 2, 3) phat.ewma.ARL <- Vectorize("phat.ewma.arl", "mu") arls <- NULL for ( i in 1:length(lambdas) ) { arls <- cbind(arls, round(phat.ewma.ARL(lambdas[i], ucls[i], mus, n, p.star, LSL=LSL, USL=USL), digits=2)) } arls <- data.frame(arls, row.names=NULL) names(arls) <- lambdas print(arls) # Table 3 \dontrun{ mus <- c(.25, .5, 1, 2) phat.ewma.LAMBDA <- Vectorize("phat.ewma.lambda", "mu") lambdas <- phat.ewma.LAMBDA(L0, mus, n, p.star, LSL=LSL, USL=USL) print(cbind(mus, lambdas))} } \keyword{ts} spc/man/xDshewhartrunsrules.arl.Rd0000644000175100001440000000647712274007677017032 0ustar hornikusers\name{xDshewhartrunsrules.arl} \alias{xDshewhartrunsrules.arl} \alias{xDshewhartrunsrulesFixedm.arl} \title{Compute ARLs of Shewhart control charts with and without runs rules under drift} \description{Computation of the zero-state Average Run Length (ARL) under drift for Shewhart control charts with and without runs rules monitoring normal mean.} \usage{xDshewhartrunsrules.arl(delta, c = 1, m = NULL, type = "12") xDshewhartrunsrulesFixedm.arl(delta, c = 1, m = 100, type = "12") } \arguments{ \item{delta}{true drift parameter.} \item{c}{normalizing constant to ensure specific alarming behavior.} \item{type}{controls the type of Shewhart chart used, seed details section.} \item{m}{parameter of Gan's approach. If \code{m=NULL}, then \code{m} will increased until the resulting ARL does not change anymore.} } \details{ Based on Gan (1991), the ARL is calculated for Shewhart control charts with and without runs rules under drift. The usual ARL function with mu=m*delta is determined and recursively via m-1, m-2, ... 1 (or 0) the drift ARL determined. \code{xDshewhartrunsrulesFixedm.arl} is the actual work horse, while \code{xDshewhartrunsrules.arl} provides a convenience wrapper. Note that Aerne et al. (1991) deployed a method that is quite similar to Gan's algorithm. For \code{type} see the help page of \code{xshewhartrunsrules.arl}. } \value{Returns a single value which resembles the ARL.} \references{ F. F. Gan (1991), EWMA control chart under linear drift, \emph{J. Stat. Comput. Simulation 38}, 181-200. L. A. Aerne, C. W. Champ and S. E. Rigdon (1991), Evaluation of control charts under linear trend, \emph{Commun. Stat., Theory Methods 20}, 3341-3349. } \author{Sven Knoth} \seealso{ \code{xshewhartrunsrules.arl} for zero-state ARL computation of Shewhart control charts with and without runs rules for the classical step change model. } \examples{ ## Aerne et al. (1991) ## Table I (continued) ## original numbers are # delta arl1of1 arl2of3 arl4of5 arl10 # 0.005623 136.67 120.90 105.34 107.08 # 0.007499 114.98 101.23 88.09 89.94 # 0.010000 96.03 84.22 73.31 75.23 # 0.013335 79.69 69.68 60.75 62.73 # 0.017783 65.75 57.38 50.18 52.18 # 0.023714 53.99 47.06 41.33 43.35 # 0.031623 44.15 38.47 33.99 36.00 # 0.042170 35.97 31.36 27.91 29.90 # 0.056234 29.21 25.51 22.91 24.86 # 0.074989 23.65 20.71 18.81 20.70 # 0.100000 19.11 16.79 15.45 17.29 # 0.133352 15.41 13.61 12.72 14.47 # 0.177828 12.41 11.03 10.50 12.14 # 0.237137 9.98 8.94 8.71 10.18 # 0.316228 8.02 7.25 7.26 8.45 # 0.421697 6.44 5.89 6.09 6.84 # 0.562341 5.17 4.80 5.15 5.48 # 0.749894 4.16 3.92 4.36 4.39 # 1.000000 3.35 3.22 3.63 3.52 c1of1 <- 3.069/3 c2of3 <- 2.1494/2 c4of5 <- 1.14 c10 <- 3.2425/3 DxDshewhartrunsrules.arl <- Vectorize(xDshewhartrunsrules.arl, "delta") deltas <- 10^(-(18:0)/8) arl1of1 <- round(DxDshewhartrunsrules.arl(deltas, c=c1of1, type="1"), digits=2) arl2of3 <- round(DxDshewhartrunsrules.arl(deltas, c=c2of3, type="12"), digits=2) arl4of5 <- round(DxDshewhartrunsrules.arl(deltas, c=c4of5, type="13"), digits=2) arl10 <- round(DxDshewhartrunsrules.arl(deltas, c=c10, type="SameSide10"), digits=2) data.frame(delta=round(deltas, digits=6), arl1of1, arl2of3, arl4of5, arl10) } \keyword{ts} spc/man/xsewma.sf.Rd0000644000175100001440000000552512273731710014044 0ustar hornikusers\name{xsewma.sf} \alias{xsewma.sf} \title{Compute the survival function of simultaneous EWMA control charts (mean and variance charts)} \description{Computation of the survival function of the Run Length (RL) for EWMA control charts monitoring simultaneously normal mean and variance.} \usage{xsewma.sf(n, lx, cx, ls, csu, df, mu, sigma, hsx=0, Nx=40, csl=0, hss=1, Ns=40, sided="upper", qm=30) } \arguments{ \item{n}{calculate sf up to value \code{n}.} \item{lx}{smoothing parameter lambda of the two-sided mean EWMA chart.} \item{cx}{control limit of the two-sided mean EWMA control chart.} \item{ls}{smoothing parameter lambda of the variance EWMA chart.} \item{csu}{upper control limit of the variance EWMA control chart.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{mu}{true mean.} \item{sigma}{true standard deviation.} \item{hsx}{so-called headstart (enables fast initial response) of the mean chart -- do not confuse with the true FIR feature considered in xewma.arl; will be updated.} \item{Nx}{dimension of the approximating matrix of the mean chart.} \item{csl}{lower control limit of the variance EWMA control chart; default value is 0; not considered if \code{sided} is \code{"upper"}.} \item{hss}{headstart (enables fast initial response) of the variance chart.} \item{Ns}{dimension of the approximating matrix of the variance chart.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{qm}{number of quadrature nodes used for the collocation integrals.} } \details{ The survival function P(L>n) and derived from it also the cdf P(L<=n) and the pmf P(L=n) illustrate the distribution of the EWMA run length. For large n the geometric tail could be exploited. That is, with reasonable large n the complete distribution is characterized. The algorithm is based on Waldmann's survival function iteration procedure and on results in Knoth (2007). } \value{Returns a vector which resembles the survival function up to a certain point.} \references{ S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{xsewma.arl} for zero-state ARL computation of simultaneous EWMA control charts. } \examples{ ## Knoth (2014?) } \keyword{ts} spc/man/xewma.arl.Rd0000644000175100001440000002474212274010114014016 0ustar hornikusers\name{xewma.arl} \alias{xewma.arl} \title{Compute ARLs of EWMA control charts} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of EWMA control charts monitoring normal mean.} \usage{xewma.arl(l,c,mu,zr=0,hs=0,sided="one",limits="fix",q=1,r=40)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{mu}{true mean.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different control limits behavior.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\ge q)}, will be determined. Note that mu0=0 is implicitely fixed.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} } \details{ In case of the EWMA chart with fixed control limits, \code{xewma.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature. If \code{limits} is not \code{"fix"}, then the method presented in Knoth (2003) is utilized. Note that for one-sided EWMA charts (\code{sided}=\code{"one"}), only \code{"vacl"} and \code{"stat"} are deployed, while for two-sided ones (\code{sided}=\code{"two"}) also \code{"fir"}, \code{"both"} (combination of \code{"fir"} and \code{"vacl"}), and \code{"Steiner"} are implemented. For details see Knoth (2004). } \value{Except for the fixed limits EWMA charts it returns a single value which resembles the ARL. For fixed limits charts, it returns a vector of length \code{q} which resembles the ARL and the sequence of conditional expected delays for \code{q}=1 and \code{q}>1, respectively.} \references{ K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. S. V. Crowder (1987), A simple method for studying run-length distributions of exponentially weighted moving average charts, \emph{Technometrics 29}, 401-407. J. M. Lucas and M. S. Saccucci (1990), Exponentially weighted moving average control schemes: Properties and enhancements, \emph{Technometrics 32}, 1-12. S. Chandrasekaran, J. R. English and R. L. Disney (1995), Modeling and analysis of EWMA control schemes with variance-adjusted control limits, \emph{IIE Transactions 277}, 282-290. T. R. Rhoads, D. C. Montgomery and C. M. Mastrangelo (1996), Fast initial response scheme for exponentially weighted moving average control chart, \emph{Quality Engineering 9}, 317-327. S. H. Steiner (1999), EWMA control charts with time-varying control limits and fast initial response, \emph{Journal of Quality Technology 31}, 75-86. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. } \author{Sven Knoth} \seealso{ \code{xcusum.arl} for zero-state ARL computation of CUSUM control charts and \code{xewma.ad} for the steady-state ARL. } \examples{ ## Waldmann (1986), one-sided EWMA l <- .75 round(xewma.arl(l,2*sqrt((2-l)/l),0,zr=-4*sqrt((2-l)/l)),digits=1) l <- .5 round(xewma.arl(l,2*sqrt((2-l)/l),0,zr=-4*sqrt((2-l)/l)),digits=1) ## original values are 209.3 and 3907.5 (in Table 2). ## Waldmann (1986), two-sided EWMA with fixed control limits l <- .75 round(xewma.arl(l,2*sqrt((2-l)/l),0,sided="two"),digits=1) l <- .5 round(xewma.arl(l,2*sqrt((2-l)/l),0,sided="two"),digits=1) ## original values are 104.0 and 1952 (in Table 1). ## Crowder (1987), two-sided EWMA with fixed control limits l1 <- .5 l2 <- .05 c <- 2 mu <- (0:16)/4 arl1 <- sapply(mu,l=l1,c=c,sided="two",xewma.arl) arl2 <- sapply(mu,l=l2,c=c,sided="two",xewma.arl) round(cbind(mu,arl1,arl2),digits=2) ## original results are (in Table 1) ## 0.00 26.45 127.53 ## 0.25 20.12 43.94 ## 0.50 11.89 18.97 ## 0.75 7.29 11.64 ## 1.00 4.91 8.38 ## 1.25 3.95* 6.56 ## 1.50 2.80 5.41 ## 1.75 2.29 4.62 ## 2.00 1.94 4.04 ## 2.25 1.70 3.61 ## 2.50 1.51 3.26 ## 2.75 1.37 2.99 ## 3.00 1.26 2.76 ## 3.25 1.18 2.56 ## 3.50 1.12 2.39 ## 3.75 1.08 2.26 ## 4.00 1.05 2.15 (* -- in Crowder (1987) typo!?) ## Lucas/Saccucci (1990) ## two-sided EWMA ## with fixed limits l1 <- .5 l2 <- .03 c1 <- 3.071 c2 <- 2.437 mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,3.5,4,5) arl1 <- sapply(mu,l=l1,c=c1,sided="two",xewma.arl) arl2 <- sapply(mu,l=l2,c=c2,sided="two",xewma.arl) round(cbind(mu,arl1,arl2),digits=2) ## original results are (in Table 3) ## 0.00 500. 500. ## 0.25 255. 76.7 ## 0.50 88.8 29.3 ## 0.75 35.9 17.6 ## 1.00 17.5 12.6 ## 1.50 6.53 8.07 ## 2.00 3.63 5.99 ## 2.50 2.50 4.80 ## 3.00 1.93 4.03 ## 3.50 1.58 3.49 ## 4.00 1.34 3.11 ## 5.00 1.07 2.55 \dontrun{ ## with fir feature l1 <- .5 l2 <- .03 c1 <- 3.071 c2 <- 2.437 hs1 <- c1/2 hs2 <- c2/2 mu <- c(0,.5,1,2,3,5) arl1 <- sapply(mu,l=l1,c=c1,hs=hs1,sided="two",limits="fir",xewma.arl) arl2 <- sapply(mu,l=l2,c=c2,hs=hs2,sided="two",limits="fir",xewma.arl) round(cbind(mu,arl1,arl2),digits=2) ## original results are (in Table 5) ## 0.0 487. 406. ## 0.5 86.1 18.4 ## 1.0 15.9 7.36 ## 2.0 2.87 3.43 ## 3.0 1.45 2.34 ## 5.0 1.01 1.57 ## Chandrasekaran, English, Disney (1995) ## two-sided EWMA with fixed and variance adjusted limits (vacl) l1 <- .25 l2 <- .1 c1s <- 2.9985 c1n <- 3.0042 c2s <- 2.8159 c2n <- 2.8452 mu <- c(0,.25,.5,.75,1,2) arl1s <- sapply(mu,l=l1,c=c1s,sided="two",xewma.arl) arl1n <- sapply(mu,l=l1,c=c1n,sided="two",limits="vacl",xewma.arl) arl2s <- sapply(mu,l=l2,c=c2s,sided="two",xewma.arl) arl2n <- sapply(mu,l=l2,c=c2n,sided="two",limits="vacl",xewma.arl) round(cbind(mu,arl1s,arl1n,arl2s,arl2n),digits=2) ## original results are (in Table 2) ## 0.00 500. 500. 500. 500. ## 0.25 170.09 167.54 105.90 96.6 ## 0.50 48.14 45.65 31.08 24.35 ## 0.75 20.02 19.72 15.71 10.74 ## 1.00 11.07 9.37 10.23 6.35 ## 2.00 3.59 2.64 4.32 2.73 ## The results in Chandrasekaran, English, Disney (1995) are not ## that accurate. Let us consider the more appropriate comparison c1s <- xewma.crit(l1,500,sided="two") c1n <- xewma.crit(l1,500,sided="two",limits="vacl") c2s <- xewma.crit(l2,500,sided="two") c2n <- xewma.crit(l2,500,sided="two",limits="vacl") mu <- c(0,.25,.5,.75,1,2) arl1s <- sapply(mu,l=l1,c=c1s,sided="two",xewma.arl) arl1n <- sapply(mu,l=l1,c=c1n,sided="two",limits="vacl",xewma.arl) arl2s <- sapply(mu,l=l2,c=c2s,sided="two",xewma.arl) arl2n <- sapply(mu,l=l2,c=c2n,sided="two",limits="vacl",xewma.arl) round(cbind(mu,arl1s,arl1n,arl2s,arl2n),digits=2) ## which demonstrate the abilities of the variance-adjusted limits ## scheme more explicitely. ## Rhoads, Montgomery, Mastrangelo (1996) ## two-sided EWMA with fixed and variance adjusted limits (vacl), ## with fir and both features l <- .03 c <- 2.437 mu <- c(0,.5,1,1.5,2,3,4) sl <- sqrt(l*(2-l)) arlfix <- sapply(mu,l=l,c=c,sided="two",xewma.arl) arlvacl <- sapply(mu,l=l,c=c,sided="two",limits="vacl",xewma.arl) arlfir <- sapply(mu,l=l,c=c,hs=c/2,sided="two",limits="fir",xewma.arl) arlboth <- sapply(mu,l=l,c=c,hs=c/2*sl,sided="two",limits="both",xewma.arl) round(cbind(mu,arlfix,arlvacl,arlfir,arlboth),digits=1) ## original results are (in Table 1) ## 0.0 477.3* 427.9* 383.4* 286.2* ## 0.5 29.7 20.0 18.6 12.8 ## 1.0 12.5 6.5 7.4 3.6 ## 1.5 8.1 3.3 4.6 1.9 ## 2.0 6.0 2.2 3.4 1.4 ## 3.0 4.0 1.3 2.4 1.0 ## 4.0 3.1 1.1 1.9 1.0 ## * -- the in-control values differ sustainably from the true values! ## Steiner (1999) ## two-sided EWMA control charts with various modifications ## fixed vs. variance adjusted limits l <- .05 c <- 3 mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,3.5,4) arlfix <- sapply(mu,l=l,c=c,sided="two",xewma.arl) arlvacl <- sapply(mu,l=l,c=c,sided="two",limits="vacl",xewma.arl) round(cbind(mu,arlfix,arlvacl),digits=1) ## original results are (in Table 2) ## 0.00 1379.0 1353.0 ## 0.25 135.0 127.0 ## 0.50 37.4 32.5 ## 0.75 20.0 15.6 ## 1.00 13.5 9.0 ## 1.50 8.3 4.5 ## 2.00 6.0 2.8 ## 2.50 4.8 2.0 ## 3.00 4.0 1.6 ## 3.50 3.4 1.3 ## 4.00 3.0 1.1 ## fir, both, and Steiner's modification l <- .03 cfir <- 2.44 cboth <- 2.54 cstein <- 2.55 hsfir <- cfir/2 hsboth <- cboth/2*sqrt(l*(2-l)) mu <- c(0,.5,1,1.5,2,3,4) arlfir <- sapply(mu,l=l,c=cfir,hs=hsfir,sided="two",limits="fir",xewma.arl) arlboth <- sapply(mu,l=l,c=cboth,hs=hsboth,sided="two",limits="both",xewma.arl) arlstein <- sapply(mu,l=l,c=cstein,sided="two",limits="Steiner",xewma.arl) round(cbind(mu,arlfir,arlboth,arlstein),digits=1) ## original values are (in Table 5) ## 0.0 383.0 384.0 391.0 ## 0.5 18.6 14.9 13.8 ## 1.0 7.4 3.9 3.6 ## 1.5 4.6 2.0 1.8 ## 2.0 3.4 1.4 1.3 ## 3.0 2.4 1.1 1.0 ## 4.0 1.9 1.0 1.0 ## SAS/QC manual 1999 ## two-sided EWMA control charts with fixed limits l <- .25 c <- 3 mu <- 1 print(xewma.arl(l,c,mu,sided="two"),digits=11) # original value is 11.154267016. ## Some recent examples for one-sided EWMA charts ## with varying limits and in the so-called stationary mode # 1. varying limits = "vacl" lambda <- .1 L0 <- 500 ## Monte Carlo results (10^9 replicates) # mu ARL s.e. # 0 500.00 0.0160 # 0.5 21.637 0.0006 # 1 6.7596 0.0001 # 1.5 3.5398 0.0001 # 2 2.3038 0.0000 # 2.5 1.7004 0.0000 # 3 1.3675 0.0000 zr <- -6 r <- 50 c <- xewma.crit(lambda, L0, zr=zr, limits="vacl", r=r) Mxewma.arl <- Vectorize(xewma.arl, "mu") mus <- (0:6)/2 arls <- round(Mxewma.arl(lambda, c, mus, zr=zr, limits="vacl", r=r), digits=4) data.frame(mus, arls) # 2. stationary mode, i. e. limits = "stat" ## Monte Carlo results (10^9 replicates) # mu ARL s.e. # 0 500.00 0.0159 # 0.5 22.313 0.0006 # 1 7.2920 0.0001 # 1.5 3.9064 0.0001 # 2 2.5131 0.0000 # 2.5 1.7983 0.0000 # 3 1.4029 0.0000 c <- xewma.crit(lambda, L0, zr=zr, limits="stat", r=r) arls <- round(Mxewma.arl(lambda, c, mus, zr=zr, limits="stat", r=r), digits=4) data.frame(mus, arls) } } \keyword{ts} spc/man/xewma.sf.prerun.Rd0000644000175100001440000001035212371131031015152 0ustar hornikusers\name{xewma.sf.prerun} \alias{xewma.sf.prerun} \title{Compute the survival function of EWMA run length in case of estimated parameters} \description{Computation of the survival function of the Run Length (RL) for EWMA control charts monitoring normal mean if the in-control mean, standard deviation, or both are estimated by a pre run.} \usage{xewma.sf.prerun(l, c, mu, n, zr=0, hs=0, sided="one", limits="fix", q=1, size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE, bound=1e-10)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{mu}{true mean.} \item{n}{calculate sf up to value \code{n}.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (give fast initial response).} \item{sided}{distinguish between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguish between different control limits behavior.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state situation for the in-control and out-of-control case, respectively, are calculated. Note that mu0=0 is implicitely fixed.} \item{size}{pre run sample size.} \item{df}{degrees of freedom of the pre run variance estimator. Typically it is simply \code{size} - 1. If the pre run is collected in batches, then also other values are needed.} \item{estimated}{name the parameter to be estimated within the \code{"mu"}, \code{"sigma"}, \code{"both"}.} \item{qm.mu}{number of quadrature nodes for convoluting the mean uncertainty.} \item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.} \item{truncate}{size of truncated tail.} \item{tail_approx}{Controls whether the geometric tail approximation is used (is faster) or not.} \item{bound}{control when the geometric tail kicks in; the larger the quicker and less accurate; \code{bound} should be larger than 0 and less than 0.001.} } \details{ The survival function P(L>n) and derived from it also the cdf P(L<=n) and the pmf P(L=n) illustrate the distribution of the EWMA run length... } \value{Returns a vector which resembles the survival function up to a certain point.} \references{ F. F. Gan (1993), An optimal design of EWMA control charts based on the median run length, \emph{J. Stat. Comput. Simulation 45}, 169-184. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. L. A. Jones, C. W. Champ, S. E. Rigdon (2001), The performance of exponentially weighted moving average charts with estimated parameters, \emph{Technometrics 43}, 156-167. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{xewma.sf} for the RL survival function of EWMA control charts w/o pre run uncertainty. } \examples{ ## Jones/Champ/Rigdon (2001) c4m <- function(m, n) sqrt(2)*gamma( (m*(n-1)+1)/2 )/sqrt( m*(n-1) )/gamma( m*(n-1)/2 ) n <- 5 # sample size # Figure 6, subfigure r=0.1 lambda <- 0.1 L <- 2.454 CDF0 <- 1 - xewma.sf(lambda, L, 0, 600, sided="two") m <- 10 # pre run size CDF1 <- 1 - xewma.sf.prerun(lambda, L/c4m(m,n), 0, 600, sided="two", size=m, df=m*(n-1), estimated="both") m <- 20 CDF2 <- 1 - xewma.sf.prerun(lambda, L/c4m(m,n), 0, 600, sided="two", size=m, df=m*(n-1), estimated="both") m <- 50 CDF3 <- 1 - xewma.sf.prerun(lambda, L/c4m(m,n), 0, 600, sided="two", size=m, df=m*(n-1), estimated="both") plot(CDF0, type="l", xlab="t", ylab=expression(P(T<=t)), xlim=c(0,500), ylim=c(0,1)) abline(v=0, h=c(0,1), col="grey", lwd=.7) points((1:5)*100, CDF0[(1:5)*100], pch=18) lines(CDF1, col="blue") points((1:5)*100, CDF1[(1:5)*100], pch=2, col="blue") lines(CDF2, col="red") points((1:5)*100, CDF2[(1:5)*100], pch=16, col="red") lines(CDF3, col="green") points((1:5)*100, CDF3[(1:5)*100], pch=5, col="green") legend("bottomright", c("Known", "m=10, n=5", "m=20, n=5", "m=50, n=5"), col=c("black", "blue", "red", "green"), pch=c(18, 2, 16, 5), lty=1) } \keyword{ts} spc/man/lns2ewma.crit.Rd0000644000175100001440000000716712274004114014615 0ustar hornikusers\name{lns2ewma.crit} \alias{lns2ewma.crit} \title{Compute critical values of EWMA ln \eqn{S^2}{S^2} control charts (variance charts)} \description{Computation of the critical values (similar to alarm limits) for different types of EWMA control charts (based on the log of the sample variance \eqn{S^2}) monitoring normal variance.} \usage{lns2ewma.crit(l,L0,df,sigma0=1,cl=NULL,cu=NULL,hs=NULL,sided="upper",mode="fixed",r=40)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{L0}{in-control ARL.} \item{df}{actual degrees of freedom, corresponds to subsample size (for known mean it is equal to the subsample size, for unknown mean it is equal to subsample size minus one.} \item{sigma0}{in-control standard deviation.} \item{cl}{deployed for \code{sided}=\code{"upper"}, that is, upper variance control chart with lower reflecting barrier \code{cl}.} \item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit (\code{mode}=\code{"fixed"}), for all other cases \code{cu} is ignored.} \item{hs}{so-called headstart (enables fast initial response) -- the default value (hs=NULL) corresponds to the in-control mean of ln \eqn{S^2}{S^2}.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart with reflection at \code{cl}), \code{"lower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit (see \code{cu}) is set and only the lower is calculated to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated). With \code{"vanilla"} limits symmetric around the in-control mean of ln \eqn{S^2}{S^2} are determined, while for \code{"eq.tails"} the in-control ARL values of two single EWMA variance charts (decompose the two-sided scheme into one lower and one upper scheme) are matched.} \item{r}{dimension of the resulting linear equation system: the larger the more accurate.} } \details{ \code{lns2ewma.crit} determines the critical values (similar to alarm limits) for given in-control ARL \code{L0} by applying secant rule and using \code{lns2ewma.arl()}. In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"} a two-dimensional secant rule is applied that also ensures that the maximum of the ARL function for given standard deviation is attained at \code{sigma0}. See Knoth (2010) and the related example. } \value{Returns the lower and upper control limit \code{cl} and \code{cu}.} \references{ C. A. Acosta-Mej\'ia and J. J. Pignatiello Jr. and B. V. Rao (1999), A comparison of control charting procedures for monitoring process dispersion, \emph{IIE Transactions 31}, 569-579. S. V. Crowder and M. D. Hamilton (1992), An EWMA for monitoring a process standard deviation, \emph{Journal of Quality Technology 24}, 12-21. S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2010), Control Charting Normal Variance -- Reflections, Curiosities, and Recommendations, in \emph{Frontiers in Statistical Quality Control 9}, H.-J. Lenz and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 3-18. } \author{Sven Knoth} \seealso{\code{lns2ewma.arl} for calculation of ARL of EWMA ln \eqn{S^2}{S^2} control charts.} \examples{ ## Knoth (2005) ## compare with Table 3 (p. 351) L0 <- 200 l <- .05 df <- 4 limits <- lns2ewma.crit(l, L0, df, cl=0, hs=0) limits["cu"] } \keyword{ts} spc/man/xgrsr.ad.Rd0000644000175100001440000000600212077526552013660 0ustar hornikusers\name{xgrsr.ad} \alias{xgrsr.ad} \title{Compute steady-state ARLs of Shiryaev-Roberts schemes} \description{Computation of the steady-state Average Run Length (ARL) for Shiryaev-Roberts schemes monitoring normal mean.} \usage{xgrsr.ad(k, g, mu1, mu0 = 0, zr = 0, sided = "one", MPT = FALSE, r = 30)} \arguments{ \item{k}{reference value of the Shiryaev-Roberts scheme.} \item{g}{control limit (alarm threshold) of Shiryaev-Roberts scheme.} \item{mu1}{out-of-control mean.} \item{mu0}{in-control mean.} \item{zr}{reflection border to enable the numerical algorithms used here.} \item{sided}{distinguishes between one- and two-sided schemes by choosing \code{"one"} and\code{"two"}, respectively. Currently only one-sided schemes are implemented.} \item{MPT}{switch between the old implementation (\code{FALSE}) and the new one (\code{TRUE}) that considers the completed likelihood ratio. MPT contains the initials of G. Moustakides, A. Polunchenko and A. Tartakovsky.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1}.} } \details{ \code{xgrsr.ad} determines the steady-state Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature. } \value{Returns a single value which resembles the steady-state ARL.} \references{ S. Knoth (2006), The art of evaluating monitoring schemes -- how to measure the performance of control charts? S. Lenz, H. & Wilrich, P. (ed.), \emph{Frontiers in Statistical Quality Control 8}, Physica Verlag, Heidelberg, Germany, 74-99. G. Moustakides, A. Polunchenko, A. Tartakovsky (2009), Numerical comparison of CUSUM and Shiryaev-Roberts procedures for detectin changes in distributions, \emph{Communications in Statistics: Theory and Methods 38}, 3225-3239. } \author{Sven Knoth} \seealso{ \code{xewma.arl} and \code{xcusum-arl} for zero-state ARL computation of EWMA and CUSUM control charts, respectively, and \code{xgrsr.arl} for the zero-state ARL. } \examples{ ## Small study to identify appropriate reflection border to mimic unreflected schemes k <- .5 g <- log(390) zrs <- -(0:10) ZRxgrsr.ad <- Vectorize(xgrsr.ad, "zr") ads <- ZRxgrsr.ad(k, g, 0, zr=zrs) data.frame(zrs, ads) ## Table 2 from Knoth (2006) ## original values are # mu arl # 0 689 # 0.5 30 # 1 8.9 # 1.5 5.1 # 2 3.6 # 2.5 2.8 # 3 2.4 # k <- .5 g <- log(390) zr <- -5 # see first example mus <- (0:6)/2 Mxgrsr.ad <- Vectorize(xgrsr.ad, "mu1") ads <- round(Mxgrsr.ad(k, g, mus, zr=zr), digits=1) data.frame(mus, ads) ## Table 4 from Moustakides et al. (2009) ## original values are # gamma A STADD/steady-state ARL # 50 28.02 4.37 # 100 56.04 5.46 # 500 280.19 8.33 # 1000 560.37 9.64 # 5000 2801.75 12.79 # 10000 5603.7 14.17 Gxgrsr.ad <- Vectorize("xgrsr.ad", "g") As <- c(28.02, 56.04, 280.19, 560.37, 2801.75, 5603.7) gs <- log(As) theta <- 1 zr <- -6 ads <- round(Gxgrsr.ad(theta/2, gs, theta, zr=zr, r=100), digits=2) data.frame(As, ads) } \keyword{ts} spc/man/sewma.arl.prerun.Rd0000644000175100001440000000502012274011665015323 0ustar hornikusers\name{sewma.arl.prerun} \alias{sewma.arl.prerun} \title{Compute ARLs of EWMA control charts (variance charts) in case of estimated parameters} \description{Computation of the (zero-state) Average Run Length (ARL) for EWMA control charts (based on the sample variance \eqn{S^2}) monitoring normal variance with estimated parameters.} \usage{sewma.arl.prerun(l, cl, cu, sigma, df1, df2, hs=1, sided="upper", r=40, qm=30, qm.sigma=30, truncate=1e-10)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{cl}{lower control limit of the EWMA control chart.} \item{cu}{upper control limit of the EWMA control chart.} \item{sigma}{true standard deviation.} \item{df1}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{df2}{degrees of freedom of the pre-run variance estimator.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}),\code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{r}{dimension of the resulting linear equation system (highest order of the collocation polynomials).} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} \item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.} \item{truncate}{size of truncated tail.} } \details{ Essentially, the ARL function \code{sewma.arl} is convoluted with the distribution of the sample standard deviation. For details see Jones/Champ/Rigdon (2001) and Knoth (2014?).} \value{Returns a single value which resembles the ARL.} \references{ L. A. Jones, C. W. Champ, S. E. Rigdon (2001), The performance of exponentially weighted moving average charts with estimated parameters, \emph{Technometrics 43}, 156-167. S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2006), Computation of the ARL for CUSUM-\eqn{S^2}{S^2} schemes, \emph{Computational Statistics & Data Analysis 51}, 499-512. } \author{Sven Knoth} \seealso{ \code{sewma.arl} for zero-state ARL function of EWMA control charts w/o pre run uncertainty. } \examples{ ## Knoth (2014?) } \keyword{ts} spc/man/xtewma.sf.Rd0000644000175100001440000000530112343300525014027 0ustar hornikusers\name{xtewma.sf} \alias{xtewma.sf} \title{Compute the survival function of EWMA run length} \description{Computation of the survival function of the Run Length (RL) for EWMA control charts monitoring normal mean.} \usage{xtewma.sf(l, c, df, mu, n, zr=0, hs=0, sided="two", limits="fix", mode="tan", q=1, r=40)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{df}{degrees of freedom -- parameter of the t distribution.} \item{mu}{true mean.} \item{n}{calculate sf up to value \code{n}.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different conrol limits behavior.} \item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently, \code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state situation for the in-control and out-of-control case, respectively, are calculated. Note that mu0=0 is implicitely fixed.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} } \details{ The survival function P(L>n) and derived from it also the cdf P(L<=n) and the pmf P(L=n) illustrate the distribution of the EWMA run length. For large n the geometric tail could be exploited. That is, with reasonable large n the complete distribution is characterized. The algorithm is based on Waldmann's survival function iteration procedure. For varying limits and for change points after 1 the algorithm from Knoth (2004) is applied. For details see Knoth (2004). } \value{Returns a vector which resembles the survival function up to a certain point.} \references{ F. F. Gan (1993), An optimal design of EWMA control charts based on the median run length, \emph{J. Stat. Comput. Simulation 45}, 169-184. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{xewma.sf} for survival function computation of EWMA control charts in the normal case. } \examples{ ## will follow } \keyword{ts} spc/man/xewma.crit.Rd0000644000175100001440000000366112044562253014211 0ustar hornikusers\name{xewma.crit} \alias{xewma.crit} \title{Compute critical values of EWMA control charts} \description{Computation of the critical values (similar to alarm limits) for different types of EWMA control charts monitoring normal mean.} \usage{xewma.crit(l,L0,mu0=0,zr=0,hs=0,sided="one",limits="fix",r=40,c0=NULL)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{L0}{in-control ARL.} \item{mu0}{in-control mean.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different control limits behavior.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} \item{c0}{starting value for iteration rule.} } \details{ \code{xewma.crit} determines the critical values (similar to alarm limits) for given in-control ARL \code{L0} by applying secant rule and using \code{xewma.arl()}. } \value{Returns a single value which resembles the critical value \code{c}.} \references{ S. V. Crowder (1989), Design of exponentially weighted moving average schemes, \emph{Journal of Quality Technology 21}, 155-162. } \author{Sven Knoth} \seealso{\code{xewma.arl} for zero-state ARL computation.} \examples{ l <- .1 incontrolARL <- c(500,5000,50000) sapply(incontrolARL,l=l,sided="two",xewma.crit,r=35) # accuracy with 35 nodes sapply(incontrolARL,l=l,sided="two",xewma.crit) # accuracy with 40 nodes sapply(incontrolARL,l=l,sided="two",xewma.crit,r=50) # accuracy with 50 nodes ## Crowder (1989) ## two-sided EWMA control charts with fixed limits l <- c(.05,.1,.15,.2,.25) L0 <- 250 round(sapply(l,L0=L0,sided="two",xewma.crit),digits=2) ## original values are 2.32, 2.55, 2.65, 2.72, and 2.76. } \keyword{ts} spc/man/xsewma.q.Rd0000644000175100001440000001020112273731577013672 0ustar hornikusers\name{xsewma.q} \alias{xsewma.q} \alias{xsewma.q.crit} \title{Compute critical values of simultaneous EWMA control charts (mean and variance charts) for given RL quantile} \description{Computation of the critical values (similar to alarm limits) for different types of simultaneous EWMA control charts (based on the sample mean and the sample variance \eqn{S^2}) monitoring normal mean and variance.} \usage{xsewma.q(lx, cx, ls, csu, df, alpha, mu, sigma, hsx=0, Nx=40, csl=0, hss=1, Ns=40, sided="upper", qm=30) xsewma.q.crit(lx, ls, L0, alpha, df, mu0=0, sigma0=1, csu=NULL, hsx=0, hss=1, sided="upper", mode="fixed", Nx=20, Ns=40, qm=30, c.error=1e-12, a.error=1e-9)} \arguments{ \item{lx}{smoothing parameter lambda of the two-sided mean EWMA chart.} \item{cx}{control limit of the two-sided mean EWMA control chart.} \item{ls}{smoothing parameter lambda of the variance EWMA chart.} \item{csu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit (\code{mode}=\code{"fixed"}, only for \code{xsewma.q.crit}) a value larger than \code{sigma0} has to been given, for all other cases \code{cu} is ignored. It is the upper control limit of the variance EWMA control chart.} \item{L0}{in-control RL quantile at level \code{alpha}.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{alpha}{quantile level.} \item{mu}{true mean.} \item{sigma}{true standard deviation.} \item{mu0}{in-control mean.} \item{sigma0}{in-control standard deviation.} \item{hsx}{so-called headstart (enables fast initial response) of the mean chart -- do not confuse with the true FIR feature considered in xewma.arl; will be updated.} \item{Nx}{dimension of the approximating matrix of the mean chart.} \item{csl}{lower control limit of the variance EWMA control chart; default value is 0; not considered if \code{sided} is \code{"upper"}.} \item{hss}{headstart (enables fast initial response) of the variance chart.} \item{Ns}{dimension of the approximating matrix of the variance chart.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of of \code{cl} is not used).} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit (see \code{cu}) is set and only the lower is determined to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated).} \item{qm}{number of quadrature nodes used for the collocation integrals.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{a.error}{error bound for the quantile level \code{alpha} during applying the secant rule.} } \details{ Instead of the popular ARL (Average Run Length) quantiles of the EWMA stopping time (Run Length) are determined. The algorithm is based on Waldmann's survival function iteration procedure and on Knoth (2007). \code{xsewma.q.crit} determines the critical values (similar to alarm limits) for given in-control RL quantile \code{L0} at level \code{alpha} by applying secant rule and using \code{xsewma.sf()}. In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"} a two-dimensional secant rule is applied that also ensures that the maximum of the RL cdf for given standard deviation is attained at \code{sigma0}. } \value{Returns a single value which resembles the RL quantile of order \code{alpha} and the critical value of the two-sided mean EWMA chart and the lower and upper controls limit \code{csl} and \code{csu} of the variance EWMA chart, respectively.} \references{ S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. } \author{Sven Knoth} \seealso{\code{xsewma.arl} for calculation of ARL of simultaneous EWMA charts and \code{xsewma.sf} for the RL survival function.} \examples{ ## Knoth (2014?) } \keyword{ts} spc/man/dphat.Rd0000644000175100001440000000611512524414762013231 0ustar hornikusers\name{dphat} \alias{dphat} \alias{pphat} \alias{qphat} \title{Percent defective for normal samples} \description{Density, distribution function and quantile function for the sample percent defective calculated on normal samples with mean equal to \code{mu} and standard deviation equal to \code{sigma}.} \usage{dphat(x, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30) pphat(q, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30) qphat(p, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30)} \arguments{ \item{x, q}{vector of quantiles.} \item{p}{vector of probabilities.} \item{n}{sample size.} \item{mu, sigma}{parameters of the underlying normal distribution.} \item{type}{choose whether the standard deviation is given and fixed (\code{"known"}) or estimated and potententially monitored (\code{"estimated"}).} \item{LSL,USL}{lower and upper specification limit, respectively.} \item{nodes}{number of quadrature nodes needed for \code{type="estimated"}.} } \details{Bruhn-Suhr/Krumbholz (1990) derived the cumulative distribution function of the sample percent defective calculated on normal samples to applying them for a new variables sampling plan. These results were heavily used in Krumbholz/Z\"{o}ller (1995) for Shewhart and in Knoth/Steinmetz (2013) for EWMA control charts. For algorithmic details see, essentially, Bruhn-Suhr/Krumbholz (1990). Two design variants are treated: The simple case, \code{type="known"}, with known normal variance and the presumably much more relevant and considerably intricate case, \code{type="estimated"}, where both parameters of the normal distribution are unknown. Basically, given lower and upper specification limits and the normal distribution, one estimates the expected yield based on a normal sample of size \code{n}. } \value{Returns vector of pdf, cdf or qf values for the statistic phat.} \references{ M. Bruhn-Suhr and W. Krumbholz (1990), A new variables sampling plan for normally distributed lots with unknown standard deviation and double specification limits, \emph{Statistical Papers} 31(1), 195-207. W. Krumbholz and A. Z\"{o}ller (1995), \code{p}-Karten vom Shewhartschen Typ f\"{u}r die messende Pr\"{u}fung, \emph{Allgemeines Statistisches Archiv} 79, 347-360. S. Knoth and S. Steinmetz (2013), EWMA \code{p} charts under sampling by variables, \emph{International Journal of Production Research} 51(13), 3795-3807. } \author{Sven Knoth} \seealso{ \code{phat.ewma.arl} for routines using the herewith considered phat statistic.} \examples{ # Figures 1 (c) and (d) from Knoth/Steinmetz (2013) n <- 5 LSL <- -3 USL <- 3 par(mar=c(5, 5, 1, 1) + 0.1) p.star <- 2*pnorm( (LSL-USL)/2 ) # for p <= p.star pdf and cdf vanish p_ <- seq(p.star+1e-10, 0.07, 0.0001) # define support of Figure 1 # Figure 1 (c) pp_ <- pphat(p_, n) plot(p_, pp_, type="l", xlab="p", ylab=expression(P( hat(p) <= p )), xlim=c(0, 0.06), ylim=c(0,1), lwd=2) abline(h=0:1, v=p.star, col="grey") # Figure 1 (d) dp_ <- dphat(p_, n) plot(p_, dp_, type="l", xlab="p", ylab="f(p)", xlim=c(0, 0.06), ylim=c(0,50), lwd=2) abline(h=0, v=p.star, col="grey") } \keyword{ts}spc/man/xewma.sf.Rd0000644000175100001440000000607712273666321013671 0ustar hornikusers\name{xewma.sf} \alias{xewma.sf} \title{Compute the survival function of EWMA run length} \description{Computation of the survival function of the Run Length (RL) for EWMA control charts monitoring normal mean.} \usage{xewma.sf(l, c, mu, n, zr=0, hs=0, sided="one", limits="fix", q=1, r=40)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{mu}{true mean.} \item{n}{calculate sf up to value \code{n}.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different control limits behavior.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state situation for the in-control and out-of-control case, respectively, are calculated. Note that mu0=0 is implicitely fixed.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} } \details{ The survival function P(L>n) and derived from it also the cdf P(L<=n) and the pmf P(L=n) illustrate the distribution of the EWMA run length. For large n the geometric tail could be exploited. That is, with reasonable large n the complete distribution is characterized. The algorithm is based on Waldmann's survival function iteration procedure. For varying limits and for change points after 1 the algorithm from Knoth (2004) is applied. Note that for one-sided EWMA charts (\code{sided}=\code{"one"}), only \code{"vacl"} and \code{"stat"} are deployed, while for two-sided ones (\code{sided}=\code{"two"}) also \code{"fir"}, \code{"both"} (combination of \code{"fir"} and \code{"vacl"}), and \code{"Steiner"} are implemented. For details see Knoth (2004). } \value{Returns a vector which resembles the survival function up to a certain point.} \references{ F. F. Gan (1993), An optimal design of EWMA control charts based on the median run length, \emph{J. Stat. Comput. Simulation 45}, 169-184. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL computation of EWMA control charts. } \examples{ ## Gan (1993), two-sided EWMA with fixed control limits ## some values of his Table 1 -- any median RL should be 500 G.lambda <- c(.05, .1, .15, .2, .25) G.h <- c(.441, .675, .863, 1.027, 1.177)/sqrt(G.lambda/(2-G.lambda)) for ( i in 1:length(G.lambda) ) { SF <- xewma.sf(G.lambda[i], G.h[i], 0, 1000) if (i==1) plot(1:length(SF), SF, type="l", xlab="n", ylab="P(L>n)") else lines(1:length(SF), SF, col=i) } } \keyword{ts} spc/man/xtewma.ad.Rd0000644000175100001440000000473112553214767014030 0ustar hornikusers\name{xtewma.ad} \alias{xtewma.ad} \title{Compute steady-state ARLs of EWMA control charts, t distributed data} \description{Computation of the steady-state Average Run Length (ARL) for different types of EWMA control charts monitoring the mean of t distributed data.} \usage{xtewma.ad(l, c, df, mu1, mu0=0, zr=0, z0=0, sided="one", limits="fix", steady.state.mode="conditional", mode="tan", r=40)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{df}{degrees of freedom -- parameter of the t distribution.} \item{mu1}{in-control mean.} \item{mu0}{out-of-control mean.} \item{zr}{reflection border for the one-sided chart.} \item{z0}{restarting value of the EWMA sequence in case of a false alarm in \code{steady.state.mode="cyclical"}.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different control limits behavior.} \item{steady.state.mode}{distinguishes between two steady-state modes -- conditional and cyclical.} \item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently, \code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} } \details{ \code{xtewma.ad} determines the steady-state Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature and using the power method for deriving the largest in magnitude eigenvalue and the related left eigenfunction. } \value{Returns a single value which resembles the steady-state ARL.} \references{ R. B. Crosier (1986), A new two-sided cumulative quality control scheme, \emph{Technometrics 28}, 187-194. S. V. Crowder (1987), A simple method for studying run-length distributions of exponentially weighted moving average charts, \emph{Technometrics 29}, 401-407. J. M. Lucas and M. S. Saccucci (1990), Exponentially weighted moving average control schemes: Properties and enhancements, \emph{Technometrics 32}, 1-12. } \author{Sven Knoth} \seealso{ \code{xtewma.arl} for zero-state ARL computation and \code{xewma.ad} for the steady-state ARL for normal data.} \examples{ ## will follow } \keyword{ts} spc/man/xcusum.crit.L0L1.Rd0000644000175100001440000000653612274007146015067 0ustar hornikusers\name{xcusum.crit.L0L1} \alias{xcusum.crit.L0L1} \title{Compute the CUSUM k and h for given in-control ARL L0 and out-of-control L1} \description{Computation of the reference value k and the alarm threshold h for one-sided CUSUM control charts monitoring normal mean, if the in-control ARL L0 and the out-of-control L1 are given.} \usage{xcusum.crit.L0L1(L0, L1, hs=0, sided="one", r=30, L1.eps=1e-6, k.eps=1e-8)} \arguments{ \item{L0}{in-control ARL.} \item{L1}{out-of-control ARL.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one-, two-sided and Crosier's modified two-sided CUSUM schemoosing \code{"one"}, \code{"two"}, and \code{"Crosier"}, respectively.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-, two-sided) or \code{2r+1} (Crosier).} \item{L1.eps}{error bound for the L1 error.} \item{k.eps}{bound for the difference of two successive values of k.} } \details{ \code{xcusum.crit.L0L1} determines the reference value k and the alarm threshold h for given in-control ARL \code{L0} and out-of-control ARL \code{L1} by applying secant rule and using \code{xcusum.arl()} and \code{xcusum.crit()}. These CUSUM design rules were firstly (and quite rarely afterwards) used by Ewan and Kemp. } \value{Returns two values which resemble the reference value \code{k} and the threshold \code{h}.} \references{ W. D. Ewan and K. W. Kemp (1960), Sampling inspection of continuous processes with no autocorrelation between successive results, \emph{Biometrika 47}, 363-380. K. W. Kemp (1962), The Use of Cumulative Sums for Sampling Inspection Schemes, \emph{Journal of the Royal Statistical Sociecty C, Applied Statistics, 10}, 16-31. } \author{Sven Knoth} \seealso{\code{xcusum.arl} for zero-state ARL and \code{xcusum.crit} for threshold h computation.} \examples{ ## Table 2 from Ewan/Kemp (1960) -- one-sided CUSUM # # A.R.L. at A.Q.L. A.R.L. at A.Q.L. k h # 1000 3 1.12 2.40 # 1000 7 0.65 4.06 # 500 3 1.04 2.26 # 500 7 0.60 3.80 # 250 3 0.94 2.11 # 250 7 0.54 3.51 # L0.set <- c(1000, 500, 250) L1.set <- c(3, 7) cat("\nL0\tL1\tk\th\n") for ( L0 in L0.set ) { for ( L1 in L1.set ) { result <- round(xcusum.crit.L0L1(L0, L1), digits=2) cat(paste(L0, L1, result[1], result[2], sep="\t"), "\n") } } # # two confirmation runs xcusum.arl(0.54, 3.51, 0) # Ewan/Kemp xcusum.arl(result[1], result[2], 0) # here xcusum.arl(0.54, 3.51, 2*0.54) # Ewan/Kemp xcusum.arl(result[1], result[2], 2*result[1]) # here # ## Table II from Kemp (1962) -- two-sided CUSUM # # Lr k # La=250 La=500 La=1000 # 2.5 1.05 1.17 1.27 # 3.0 0.94 1.035 1.13 # 4.0 0.78 0.85 0.92 # 5.0 0.68 0.74 0.80 # 6.0 0.60 0.655 0.71 # 7.5 0.52 0.57 0.62 # 10.0 0.43 0.48 0.52 # L0.set <- c(250, 500, 1000) L1.set <- c(2.5, 3:6, 7.5, 10) cat("\nL1\tL0=250\tL0=500\tL0=1000\n") for ( L1 in L1.set ) { cat(L1) for ( L0 in L0.set ) { result <- round(xcusum.crit.L0L1(L0, L1, sided="two"), digits=2) cat("\t", result[1]) } cat("\n") } } \keyword{ts} spc/man/xewma.q.prerun.Rd0000644000175100001440000001125112371130247015011 0ustar hornikusers\name{xewma.q.prerun} \alias{xewma.q.prerun} \alias{xewma.q.crit.prerun} \title{Compute RL quantiles of EWMA control charts in case of estimated parameters} \description{Computation of quantiles of the Run Length (RL) for EWMA control charts monitoring normal mean if the in-control mean, standard deviation, or both are estimated by a pre run.} \usage{xewma.q.prerun(l, c, mu, p, zr=0, hs=0, sided="two", limits="fix", q=1, size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, bound=1e-10) xewma.q.crit.prerun(l, L0, mu, p, zr=0, hs=0, sided="two", limits="fix", size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, bound=1e-10, c.error=1e-10, p.error=1e-9, OUTPUT=FALSE)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{mu}{true mean shift.} \item{p}{quantile level.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (give fast initial response).} \item{sided}{distinguish between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguish between different control limits behavior.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\geq)}, will be determined. Note that mu0=0 is implicitely fixed.} \item{size}{pre run sample size.} \item{df}{Degrees of freedom of the pre run variance estimator. Typically it is simply \code{size} - 1. If the pre run is collected in batches, then also other values are needed.} \item{estimated}{name the parameter to be estimated within the \code{"mu"}, \code{"sigma"}, \code{"both"}.} \item{qm.mu}{number of quadrature nodes for convoluting the mean uncertainty.} \item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.} \item{truncate}{size of truncated tail.} \item{bound}{control when the geometric tail kicks in; the larger the quicker and less accurate; \code{bound} should be larger than 0 and less than 0.001.} \item{L0}{in-control quantile value.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{p.error}{error bound for the quantile level \code{p} during applying the secant rule.} \item{OUTPUT}{activate or deactivate additional output.} } \details{ Essentially, the ARL function \code{xewma.q} is convoluted with the distribution of the sample mean, standard deviation or both. For details see Jones/Champ/Rigdon (2001) and Knoth (2014?). } \value{Returns a single value which resembles the RL quantile of order \code{q}.} \references{ L. A. Jones, C. W. Champ, S. E. Rigdon (2001), The performance of exponentially weighted moving average charts with estimated parameters, \emph{Technometrics 43}, 156-167. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. S. Knoth (2014?), tbd, \emph{tbd}, tbd-tbd. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{xewma.q} for the usual RL quantiles computation of EWMA control charts. } \examples{ ## Jones/Champ/Rigdon (2001) c4m <- function(m, n) sqrt(2)*gamma( (m*(n-1)+1)/2 )/sqrt( m*(n-1) )/gamma( m*(n-1)/2 ) n <- 5 # sample size m <- 20 # pre run with 20 samples of size n = 5 C4m <- c4m(m, n) # needed for bias correction # Table 1, 3rd column lambda <- 0.2 L <- 2.636 xewma.Q <- Vectorize("xewma.q", "mu") xewma.Q.prerun <- Vectorize("xewma.q.prerun", "mu") mu <- c(0, .25, .5, 1, 1.5, 2) Q1 <- ceiling(xewma.Q(lambda, L, mu, 0.1, sided="two")) Q2 <- ceiling(xewma.Q(lambda, L, mu, 0.5, sided="two")) Q3 <- ceiling(xewma.Q(lambda, L, mu, 0.9, sided="two")) cbind(mu, Q1, Q2, Q3) \dontrun{ p.Q1 <- xewma.Q.prerun(lambda, L/C4m, mu, 0.1, sided="two", size=m, df=m*(n-1), estimated="both") p.Q2 <- xewma.Q.prerun(lambda, L/C4m, mu, 0.5, sided="two", size=m, df=m*(n-1), estimated="both") p.Q3 <- xewma.Q.prerun(lambda, L/C4m, mu, 0.9, sided="two", size=m, df=m*(n-1), estimated="both") cbind(mu, p.Q1, p.Q2, p.Q3) } ## original values are # mu Q1 Q2 Q3 p.Q1 p.Q2 p.Q3 # 0.00 25 140 456 13 73 345 # 0.25 12 56 174 9 46 253 # 0.50 7 20 56 6 20 101 # 1.00 4 7 15 3 7 18 # 1.50 3 4 7 2 4 8 # 2.00 2 3 5 2 3 5 } \keyword{ts} spc/man/mewma.crit.Rd0000644000175100001440000000245412272666036014204 0ustar hornikusers\name{mewma.crit} \alias{mewma.crit} \title{Compute alarm threshold of MEWMA control charts} \description{Computation of the alarm threshold for multivariate exponentially weighted moving average (MEWMA) charts monitoring multivariate normal mean.} \usage{mewma.crit(l, L0, p, hs=0, r=20)} \arguments{ \item{l}{smoothing parameter lambda of the MEWMA control chart.} \item{L0}{in-control ARL.} \item{p}{dimension of multivariate normal distribution.} \item{hs}{so-called headstart (enables fast initial response) -- must be non-negative.} \item{r}{number of quadrature nodes -- dimension of the resulting linear equation system.} } \details{ \code{mewma.crit} determines the alarm threshold of for given in-control ARL \code{L0} by applying secant rule and using \code{mewma.arl()} with \code{ntype="gl2"}. } \value{Returns a single value which resembles the critical value \code{c}.} \references{ Steven E. Rigdon (1995), An integral equation for the in-control average run length of a multivariate exponentially weighted moving average control chart, \emph{J. Stat. Comput. Simulation 52}, 351-365. } \author{Sven Knoth} \seealso{\code{mewma.arl} for zero-state ARL computation.} \examples{ # Rigdon (1995), p. 358, Tab. 1 p <- 4 L0 <- 500 r <- .25 h4 <- mewma.crit(r, L0, p) h4 ## original value is 16.38. } \keyword{ts} spc/man/xewma.arl.prerun.Rd0000644000175100001440000001050012273740104015323 0ustar hornikusers\name{xewma.arl.prerun} \alias{xewma.arl.prerun} \alias{xewma.crit.prerun} \title{Compute ARLs of EWMA control charts in case of estimated parameters} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of EWMA control charts monitoring normal mean if the in-control mean, standard deviation, or both are estimated by a pre run.} \usage{xewma.arl.prerun(l, c, mu, zr=0, hs=0, sided="two", limits="fix", q=1, size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10) xewma.crit.prerun(l, L0, mu, zr=0, hs=0, sided="two", limits="fix", size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, c.error=1e-12, L.error=1e-9, OUTPUT=FALSE)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{mu}{true mean shift.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (give fast initial response).} \item{sided}{distinguish between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguish between different control limits behavior.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\ge q)}, will be determined. Note that mu0=0 is implicitely fixed.} \item{size}{pre run sample size.} \item{df}{Degrees of freedom of the pre run variance estimator. Typically it is simply \code{size} - 1. If the pre run is collected in batches, then also other values are needed.} \item{estimated}{name the parameter to be estimated within the \code{"mu"}, \code{"sigma"}, \code{"both"}.} \item{qm.mu}{number of quadrature nodes for convoluting the mean uncertainty.} \item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.} \item{truncate}{size of truncated tail.} \item{L0}{in-control ARL.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{L.error}{error bound for the ARL level \code{L0} during applying the secant rule.} \item{OUTPUT}{activate or deactivate additional output.} } \details{ Essentially, the ARL function \code{xewma.arl} is convoluted with the distribution of the sample mean, standard deviation or both. For details see Jones/Champ/Rigdon (2001) and Knoth (2014?). } \value{Returns a single value which resembles the ARL.} \references{ L. A. Jones, C. W. Champ, S. E. Rigdon (2001), The performance of exponentially weighted moving average charts with estimated parameters, \emph{Technometrics 43}, 156-167. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. S. Knoth (2014?), tbd, \emph{tbd}, tbd-tbd. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for the usual zero-state ARL computation. } \examples{ ## Jones/Champ/Rigdon (2001) c4m <- function(m, n) sqrt(2)*gamma( (m*(n-1)+1)/2 )/sqrt( m*(n-1) )/gamma( m*(n-1)/2 ) n <- 5 # sample size m <- 20 # pre run with 20 samples of size n = 5 C4m <- c4m(m, n) # needed for bias correction # Table 1, 3rd column lambda <- 0.2 L <- 2.636 xewma.ARL <- Vectorize("xewma.arl", "mu") xewma.ARL.prerun <- Vectorize("xewma.arl.prerun", "mu") mu <- c(0, .25, .5, 1, 1.5, 2) ARL <- round(xewma.ARL(lambda, L, mu, sided="two"), digits=2) p.ARL <- round(xewma.ARL.prerun(lambda, L/C4m, mu, sided="two", size=m, df=m*(n-1), estimated="both", qm.mu=70), digits=2) # Monte-Carlo with 10^8 repetitions: 200.325 (0.020) and 144.458 (0.022) cbind(mu, ARL, p.ARL) \dontrun{ # Figure 5, subfigure r = 0.2 mu_ <- (0:85)/40 ARL_ <- round(xewma.ARL(lambda, L, mu_, sided="two"), digits=2) p.ARL_ <- round(xewma.ARL.prerun(lambda, L/C4m, mu_, sided="two", size=m, df=m*(n-1), estimated="both"), digits=2) plot(mu_, ARL_, type="l", xlab=expression(delta), ylab="ARL", xlim=c(0,2)) abline(v=0, h=0, col="grey", lwd=.7) points(mu, ARL, pch=5) lines(mu_, p.ARL_, col="blue") points(mu, p.ARL, pch=18, col ="blue") legend("topright", c("Known", "Estimated"), col=c("black", "blue"), lty=1, pch=c(5, 18)) } } \keyword{ts} spc/man/xDgrsr.arl.Rd0000644000175100001440000000751212273737676014176 0ustar hornikusers\name{xDgrsr.arl} \alias{xDgrsr.arl} \title{Compute ARLs of Shiryaev-Roberts schemes under drift} \description{Computation of the (zero-state and other) Average Run Length (ARL) under drift for Shiryaev-Roberts schemes monitoring normal mean.} \usage{xDgrsr.arl(k, g, delta, zr = 0, hs = NULL, sided = "one", m = NULL, mode = "Gan", q = 1, r = 30, with0 = FALSE)} \arguments{ \item{k}{reference value of the Shiryaev-Roberts scheme.} \item{g}{control limit (alarm threshold) of Shiryaev-Roberts scheme.} \item{delta}{true drift parameter.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided Shiryaev-Roberts schemes by choosing \code{"one"} and \code{"two"}, respectively. Currentlly, the two-sided scheme is not implemented.} \item{m}{parameter used if \code{mode="Gan"}. \code{m} is design parameter of Gan's approach. If \code{m=NULL}, then \code{m} will increased until the resulting ARL does not change anymore.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\geq)}, will be determined. Note that mu0=0 is implicitely fixed. Deploy large \code{q} to mimic steady-state. It works only for \code{mode="Knoth"}.} \item{mode}{decide whether Gan's or Knoth's approach is used. Use \code{"Gan"} and \code{"Knoth"}, respectively. \code{"Knoth"} is not implemented yet.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} \item{with0}{defines whether the first observation used for the RL calculation follows already 1*delta or still 0*delta. With \code{q} additional flexibility is given.} } \details{ Based on Gan (1991) or Knoth (2003), the ARL is calculated for Shiryaev-Roberts schemes under drift. In case of Gan's framework, the usual ARL function with mu=m*delta is determined and recursively via m-1, m-2, ... 1 (or 0) the drift ARL determined. The framework of Knoth allows to calculate ARLs for varying parameters, such as control limits and distributional parameters. For details see the cited papers. } \value{Returns a single value which resembles the ARL.} \references{ F. F. Gan (1991), EWMA control chart under linear drift, \emph{J. Stat. Comput. Simulation 38}, 181-200. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2012), More on Control Charting under Drift, in: \emph{Frontiers in Statistical Quality Control 10}, H.-J. Lenz, W. Schmid and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 53-68. C. Zou, Y. Liu and Z. Wang (2009), Comparisons of control schemes for monitoring the means of processes subject to drifts, \emph{Metrika 70}, 141-163. } \author{Sven Knoth} \seealso{ \code{xewma.arl} and \code{xewma.ad} for zero-state and steady-state ARL computation of EWMA control charts for the classical step change model. } \examples{ \dontrun{ ## Monte Carlo example with 10^8 replicates # delta arl s.e. # 0.0001 381.8240 0.0304 # 0.0005 238.4630 0.0148 # 0.001 177.4061 0.0097 # 0.002 125.9055 0.0061 # 0.005 75.7574 0.0031 # 0.01 50.2203 0.0018 # 0.02 32.9458 0.0011 # 0.05 18.9213 0.0005 # 0.1 12.6054 0.0003 # 0.5 5.2157 0.0001 # 1 3.6537 0.0001 # 3 2.0289 0.0000 k <- .5 L0 <- 500 zr <- -7 r <- 50 g <- xgrsr.crit(k, L0, zr=zr, r=r) DxDgrsr.arl <- Vectorize(xDgrsr.arl, "delta") deltas <- c(0.0001, 0.0005, 0.001, 0.002, 0.005, 0.01, 0.02, 0.05, 0.1, 0.5, 1, 3) arls <- round(DxDgrsr.arl(k, g, deltas, zr=zr, r=r), digits=4) data.frame(deltas, arls) } } \keyword{ts} spc/man/xcusum.crit.Rd0000644000175100001440000000263412273663441014420 0ustar hornikusers\name{xcusum.crit} \alias{xcusum.crit} \title{Compute decision intervals of CUSUM control charts} \description{Computation of the decision intervals (alarm limits) for different types of CUSUM control charts monitoring normal mean.} \usage{xcusum.crit(k, L0, mu0 = 0, hs = 0, sided = "one", r = 30)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{L0}{in-control ARL.} \item{mu0}{in-control mean.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one-, two-sided and Crosier's modified two-sided CUSUM scheme by choosing \code{"one"}, \code{"two"}, and \code{"Crosier"}, respectively.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-, two-sided) or \code{2r+1} (Crosier).} } \details{ \code{xcusum.crit} determines the decision interval (alarm limit) for given in-control ARL \code{L0} by applying secant rule and using \code{xcusum.arl()}. } \value{Returns a single value which resembles the decision interval \code{h}.} %\references{Later...} \author{Sven Knoth} \seealso{\code{xcusum.arl} for zero-state ARL computation.} \examples{ k <- .5 incontrolARL <- c(500,5000,50000) sapply(incontrolARL,k=k,xcusum.crit,r=10) # accuracy with 10 nodes sapply(incontrolARL,k=k,xcusum.crit,r=20) # accuracy with 20 nodes sapply(incontrolARL,k=k,xcusum.crit) # accuracy with 30 nodes } \keyword{ts} spc/man/xsresewma.arl.Rd0000644000175100001440000001644512273740170014727 0ustar hornikusers\name{x.res.ewma.arl} \alias{x.res.ewma.arl} \alias{s.res.ewma.arl} \alias{xs.res.ewma.arl} \alias{xs.res.ewma.pms} \title{Compute ARLs of EWMA residual control charts} \description{Computation of the (zero-state) Average Run Length (ARL) for EWMA residual control charts monitoring normal mean, variance, or mean and variance simultaneously. Additionally, the probability of misleading signals (PMS) is calculated.} \usage{x.res.ewma.arl(l, c, mu, alpha=0, n=5, hs=0, r=40) s.res.ewma.arl(l, cu, sigma, mu=0, alpha=0, n=5, hs=1, r=40, qm=30) xs.res.ewma.arl(lx, cx, ls, csu, mu, sigma, alpha=0, n=5, hsx=0, rx=40, hss=1, rs=40, qm=30) xs.res.ewma.pms(lx, cx, ls, csu, mu, sigma, type="3", alpha=0, n=5, hsx=0, rx=40, hss=1, rs=40, qm=30) } \arguments{ \item{l, lx, ls}{smoothing parameter(s) lambda of the EWMA control chart.} \item{c, cu, cx, csu}{critical value (similar to alarm limit) of the EWMA control charts.} \item{mu}{true mean.} \item{sigma}{true standard deviation.} \item{alpha}{the AR(1) coefficient -- first order autocorrelation of the original data.} \item{n}{batch size.} \item{hs, hsx, hss}{so-called headstart (enables fast initial response).} \item{r, rx, rs}{number of quadrature nodes or size of collocation base, dimension of the resulting linear equation system is equal to \code{r} (two-sided).} \item{qm}{number of nodes for collocation quadratures.} \item{type}{PMS type, for \code{PMS}="3" (the default) the probability of getting a mean signal despite the variance changed, and for \code{PMS}="4" the opposite case is dealt with.} } \details{ The above list of functions provides the application of algorithms developed for iid data to the residual case. To be more precise, the underlying model is a sequence of normally distributed batches with size \code{n} with autocorrelation within the batch and independence between the batches (see also the references below). It is restricted to the classical EWMA chart types, that is two-sided for the mean, upper charts for the variance, and all equipped with fixed limits. The autocorrelation is modeled by an AR(1) process with parameter \code{alpha}. Additionally, with \code{xs.res.ewma.pms} the probability of misleading signals (PMS) of \code{type} is calculated. This is offered exclusively in this small collection so that for iid data this function has to be used too (with \code{alpha=0}). } \value{Return single values which resemble the ARL and the PMS, respectively.} \references{ S. Knoth, M. C. Morais, A. Pacheco, W. Schmid (2009), Misleading Signals in Simultaneous Residual Schemes for the Mean and Variance of a Stationary Process, \emph{Commun. Stat., Theory Methods 38}, 2923-2943. S. Knoth, W. Schmid, A. Schoene (2001), Simultaneous Shewhart-Type Charts for the Mean and the Variance of a Time Series, \emph{Frontiers of Statistical Quality Control 6, A. Lenz, H.-J. & Wilrich, P.-T. (Eds.)}, 6, 61-79. S. Knoth, W. Schmid (2002) Monitoring the mean and the variance of a stationary process, \emph{Statistica Neerlandica 56}, 77-100. } \author{Sven Knoth} \seealso{ \code{xewma.arl}, \code{sewma.arl}, and \code{xsewma.arl} as more elaborated functions in the iid case.} \examples{ \dontrun{ ## S. Knoth, W. Schmid (2002) cat("\nFragments of Table 2 (n=5, lambda.1=lambda.2)\n") lambdas <- c(.5, .25, .1, .05) L0 <- 500 n <- 5 crit <- NULL for ( lambda in lambdas ) { cs <- xsewma.crit(lambda, lambda, L0, n-1) x.e <- round(cs[1], digits=4) names(x.e) <- NULL s.e <- round((cs[3]-1) * sqrt((2-lambda)/lambda)*sqrt((n-1)/2), digits=4) names(s.e) <- NULL crit <- rbind(crit, data.frame(lambda, x.e, s.e)) } ## orinal values are (Markov chain approximation with 50 states) # lambda x.e s.e # 0.50 3.2765 4.6439 # 0.25 3.2168 4.0149 # 0.10 3.0578 3.3376 # 0.05 2.8817 2.9103 print(crit) cat("\nFragments of Table 4 (n=5, lambda.1=lambda.2=0.1)\n\n") lambda <- .1 # the algorithm used in Knoth/Schmid is less accurate -- proceed with their values cx <- x.e <- 3.0578 s.e <- 3.3376 csu <- 1 + s.e * sqrt(lambda/(2-lambda))*sqrt(2/(n-1)) alpha <- .3 a.values <- c((0:6)/4, 2) d.values <- c(1 + (0:5)/10, 1.75 , 2) arls <- NULL for ( delta in d.values ) { row <- NULL for ( mu in a.values ) { arl <- round(xs.res.ewma.arl(lambda, cx, lambda, csu, mu*sqrt(n), delta, alpha=alpha, n=n), digits=2) names(arl) <- NULL row <- c(row, arl) } arls <- rbind(arls, data.frame(t(row))) } names(arls) <- a.values rownames(arls) <- d.values ## orinal values are (now Monte-Carlo with 10^6 replicates) # 0 0.25 0.5 0.75 1 1.25 1.5 2 #1 502.44 49.50 14.21 7.93 5.53 4.28 3.53 2.65 #1.1 73.19 32.91 13.33 7.82 5.52 4.29 3.54 2.66 #1.2 24.42 18.88 11.37 7.44 5.42 4.27 3.54 2.67 #1.3 13.11 11.83 9.09 6.74 5.18 4.17 3.50 2.66 #1.4 8.74 8.31 7.19 5.89 4.81 4.00 3.41 2.64 #1.5 6.50 6.31 5.80 5.08 4.37 3.76 3.28 2.59 #1.75 3.94 3.90 3.78 3.59 3.35 3.09 2.83 2.40 #2 2.85 2.84 2.80 2.73 2.63 2.51 2.39 2.14 print(arls) ## S. Knoth, M. C. Morais, A. Pacheco, W. Schmid (2009) cat("\nFragments of Table 5 (n=5, lambda=0.1)\n\n") d.values <- c(1.02, 1 + (1:5)/10, 1.75 , 2) arl.x <- arl.s <- arl.xs <- PMS.3 <- NULL for ( delta in d.values ) { arl.x <- c(arl.x, round(x.res.ewma.arl(lambda, cx/delta, 0, n=n), digits=3)) arl.s <- c(arl.s, round(s.res.ewma.arl(lambda, csu, delta, n=n), digits=3)) arl.xs <- c(arl.xs, round(xs.res.ewma.arl(lambda, cx, lambda, csu, 0, delta, n=n), digits=3)) PMS.3 <- c(PMS.3, round(xs.res.ewma.pms(lambda, cx, lambda, csu, 0, delta, n=n), digits=6)) } ## orinal values are (Markov chain approximation) # delta arl.x arl.s arl.xs PMS.3 # 1.02 833.086 518.935 323.324 0.381118 # 1.10 454.101 84.208 73.029 0.145005 # 1.20 250.665 25.871 24.432 0.071024 # 1.30 157.343 13.567 13.125 0.047193 # 1.40 108.112 8.941 8.734 0.035945 # 1.50 79.308 6.614 6.493 0.029499 # 1.75 44.128 3.995 3.942 0.021579 # 2.00 28.974 2.887 2.853 0.018220 print(cbind(delta=d.values, arl.x, arl.s, arl.xs, PMS.3)) cat("\nFragments of Table 6 (n=5, lambda=0.1)\n\n") alphas <- c(-0.9, -0.5, -0.3, 0, 0.3, 0.5, 0.9) deltas <- c(0.05, 0.25, 0.5, 0.75, 1, 1.25, 1.5, 2) PMS.4 <- NULL for ( ir in 1:length(deltas) ) { mu <- deltas[ir]*sqrt(n) pms <- NULL for ( alpha in alphas ) { pms <- c(pms, round(xs.res.ewma.pms(lambda, cx, lambda, csu, mu, 1, type="4", alpha=alpha, n=n), digits=6)) } PMS.4 <- rbind(PMS.4, data.frame(delta=deltas[ir], t(pms))) } names(PMS.4) <- c("delta", alphas) rownames(PMS.4) <- NULL ## orinal values are (Markov chain approximation) # delta -0.9 -0.5 -0.3 0 0.3 0.5 0.9 # 0.05 0.055789 0.224521 0.279842 0.342805 0.391299 0.418915 0.471386 # 0.25 0.003566 0.009522 0.014580 0.025786 0.044892 0.066584 0.192023 # 0.50 0.002994 0.001816 0.002596 0.004774 0.009259 0.015303 0.072945 # 0.75 0.006967 0.000703 0.000837 0.001529 0.003400 0.006424 0.046602 # 1.00 0.005098 0.000402 0.000370 0.000625 0.001589 0.003490 0.039978 # 1.25 0.000084 0.000266 0.000202 0.000300 0.000867 0.002220 0.039773 # 1.50 0.000000 0.000256 0.000120 0.000163 0.000531 0.001584 0.042734 # 2.00 0.000000 0.000311 0.000091 0.000056 0.000259 0.001029 0.054543 print(PMS.4) } } \keyword{ts} spc/man/xcusum.arl.Rd0000644000175100001440000001240712100227153014215 0ustar hornikusers\name{xcusum.arl} \alias{xcusum.arl} \title{Compute ARLs of CUSUM control charts} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of CUSUM control charts monitoring normal mean.} \usage{xcusum.arl(k, h, mu, hs = 0, sided = "one", method = "igl", q = 1, r = 30)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.} \item{mu}{true mean.} \item{hs}{so-called headstart (give fast initial response).} \item{sided}{distinguish between one-, two-sided and Crosier's modified two-sided CUSUM scheme by choosing \code{"one"}, \code{"two"}, and \code{"Crosier"}, respectively.} \item{method}{deploy the integral equation (\code{"igl"}) or Markov chain approximation (\code{"mc"}) method to calculate the ARL (currently only for two-sided CUSUM implemented).} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\ge q)}, will be determined. Note that mu0=0 is implicitely fixed.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-, two-sided) or \code{2r+1} (Crosier).} } \details{ \code{xcusum.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature. } \value{Returns a vector of length \code{q} which resembles the ARL and the sequence of conditional expected delays for \code{q}=1 and \code{q}>1, respectively.} \references{ A. L. Goel, S. M. Wu (1971), Determination of A.R.L. and a contour nomogram for CUSUM charts to control normal mean, \emph{Technometrics 13}, 221-230. D. Brook, D. A. Evans (1972), An approach to the probability distribution of cusum run length, \emph{Biometrika 59}, 539-548. J. M. Lucas, R. B. Crosier (1982), Fast initial response for cusum quality-control schemes: Give your cusum a headstart, \emph{Technometrics 24}, 199-205. L. C. Vance (1986), Average run lengths of cumulative sum control charts for controlling normal means, \emph{Journal of Quality Technology 18}, 189-193. K.-H. Waldmann (1986), Bounds for the distribution of the run length of one-sided and two-sided CUSUM quality control schemes, \emph{Technometrics 28}, 61-67. R. B. Crosier (1986), A new two-sided cumulative quality control scheme, \emph{Technometrics 28}, 187-194. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL computation of EWMA control charts and \code{xcusum.ad} for the steady-state ARL. } \examples{ ## Brook/Evans (1972), one-sided CUSUM ## Their results are based on the less accurate Markov chain approach. k <- .5 h <- 3 round(c( xcusum.arl(k,h,0), xcusum.arl(k,h,1.5) ),digits=2) ## results in the original paper are L0 = 117.59, L1 = 3.75 (in Subsection 4.3). ## Lucas, Crosier (1982) ## (one- and) two-sided CUSUM with possible headstarts k <- .5 h <- 4 mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,4,5) arl1 <- sapply(mu,k=k,h=h,sided="two",xcusum.arl) arl2 <- sapply(mu,k=k,h=h,hs=h/2,sided="two",xcusum.arl) round(cbind(mu,arl1,arl2),digits=2) ## results in the original paper are (in Table 1) ## 0.00 168. 149. ## 0.25 74.2 62.7 ## 0.50 26.6 20.1 ## 0.75 13.3 8.97 ## 1.00 8.38 5.29 ## 1.50 4.75 2.86 ## 2.00 3.34 2.01 ## 2.50 2.62 1.59 ## 3.00 2.19 1.32 ## 4.00 1.71 1.07 ## 5.00 1.31 1.01. ## Vance (1986), one-sided CUSUM ## The first paper on using Nystroem method and Gauss-Legendre quadrature ## for solving the ARL integral equation (see as well Goel/Wu, 1971) k <- 0 h <- 10 mu <- c(-.25,-.125,0,.125,.25,.5,.75,1) round(cbind(mu,sapply(mu,k=k,h=h,xcusum.arl)),digits=2) ## results in the original paper are (in Table 1 incl. Goel/Wu (1971) results) ## -0.25 2071.51 ## -0.125 400.28 ## 0.0 124.66 ## 0.125 59.30 ## 0.25 36.71 ## 0.50 20.37 ## 0.75 14.06 ## 1.00 10.75. ## Waldmann (1986), ## one- and two-sided CUSUM ## one-sided case k <- .5 h <- 3 mu <- c(-.5,0,.5) round(sapply(mu,k=k,h=h,xcusum.arl),digits=2) ## results in the original paper are 1963, 117.4, and 17.35, resp. ## (in Tables 3, 1, and 5, resp.). ## two-sided case k <- .6 h <- 3 round(xcusum.arl(k,h,-.2,sided="two"),digits=1) # fits to Waldmann's setup ## result in the original paper is 65.4 (in Table 6). ## Crosier (1986), Crosier's modified two-sided CUSUM ## He introduced the modification and evaluated it by means of ## Markov chain approximation k <- .5 h <- 3.73 mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,4,5) round(cbind(mu,sapply(mu,k=k,h=h,sided="Crosier",xcusum.arl)),digits=2) ## results in the original paper are (in Table 3) ## 0.00 168. ## 0.25 70.7 ## 0.50 25.1 ## 0.75 12.5 ## 1.00 7.92 ## 1.50 4.49 ## 2.00 3.17 ## 2.50 2.49 ## 3.00 2.09 ## 4.00 1.60 ## 5.00 1.22. ## SAS/QC manual 1999 ## one- and two-sided CUSUM schemes ## one-sided k <- .25 h <- 8 mu <- 2.5 print(xcusum.arl(k,h,mu),digits=12) print(xcusum.arl(k,h,mu,hs=.1),digits=12) ## original results are 4.1500836225 and 4.1061588131. ## two-sided print(xcusum.arl(k,h,mu,sided="two"),digits=12) ## original result is 4.1500826715. } \keyword{ts} spc/man/xgrsr.arl.Rd0000644000175100001440000001171212077745547014065 0ustar hornikusers\name{xgrsr.arl} \alias{xgrsr.arl} \title{Compute (zero-state) ARLs of Shiryaev-Roberts schemes} \description{Computation of the (zero-state) Average Run Length (ARL) for Shiryaev-Roberts schemes monitoring normal mean.} \usage{xgrsr.arl(k, g, mu, zr = 0, hs=NULL, sided = "one", q = 1, MPT = FALSE, r = 30)} \arguments{ \item{k}{reference value of the Shiryaev-Roberts scheme.} \item{g}{control limit (alarm threshold) of Shiryaev-Roberts scheme.} \item{mu}{true mean.} \item{zr}{reflection border to enable the numerical algorithms used here.} \item{hs}{so-called headstart (enables fast initial response). If \code{hs=NULL}, then the classical headstart -Inf is used (corresponds to 0 for the non-log scheme).} \item{sided}{distinguishes between one- and two-sided schemes by choosing \code{"one"} and\code{"two"}, respectively. Currently only one-sided schemes are implemented.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\ge q)}, will be determined. Note that mu0=0 is implicitely fixed.} \item{MPT}{switch between the old implementation (\code{FALSE}) and the new one (\code{TRUE}) that considers the complete likelihood ratio. MPT stands for the initials of G. Moustakides, A. Polunchenko and A. Tartakovsky.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1}.} } \details{ \code{xgrsr.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature. } \value{Returns a vector of length \code{q} which resembles the ARL and the sequence of conditional expected delays for \code{q}=1 and \code{q}>1, respectively.} \references{ S. Knoth (2006), The art of evaluating monitoring schemes -- how to measure the performance of control charts? S. Lenz, H. & Wilrich, P. (ed.), \emph{Frontiers in Statistical Quality Control 8}, Physica Verlag, Heidelberg, Germany, 74-99. G. Moustakides, A. Polunchenko, A. Tartakovsky (2009), Numerical comparison of CUSUM and Shiryaev-Roberts procedures for detecting changes in distributions, \emph{Communications in Statistics: Theory and Methods 38}, 3225-3239. } \author{Sven Knoth} \seealso{ \code{xewma.arl} and \code{xcusum-arl} for zero-state ARL computation of EWMA and CUSUM control charts, respectively, and \code{xgrsr.ad} for the steady-state ARL. } \examples{ ## Small study to identify appropriate reflection border to mimic unreflected schemes k <- .5 g <- log(390) zrs <- -(0:10) ZRxgrsr.arl <- Vectorize(xgrsr.arl, "zr") arls <- ZRxgrsr.arl(k, g, 0, zr=zrs) data.frame(zrs, arls) ## Table 2 from Knoth (2006) ## original values are # mu arl # 0 697 # 0.5 33 # 1 10.4 # 1.5 6.2 # 2 4.4 # 2.5 3.5 # 3 2.9 # k <- .5 g <- log(390) zr <- -5 # see first example mus <- (0:6)/2 Mxgrsr.arl <- Vectorize(xgrsr.arl, "mu") arls <- round(Mxgrsr.arl(k, g, mus, zr=zr), digits=1) data.frame(mus, arls) XGRSR.arl <- Vectorize("xgrsr.arl", "g") zr <- -6 ## Table 2 from Moustakides et al. (2009) ## original values are # gamma A ARL/E_infty(L) SADD/E_1(L) # 50 47.17 50.29 41.40 # 100 94.34 100.28 72.32 # 500 471.70 500.28 209.44 # 1000 943.41 1000.28 298.50 # 5000 4717.04 5000.24 557.87 #10000 9434.08 10000.17 684.17 theta <- .1 As2 <- c(47.17, 94.34, 471.7, 943.41, 4717.04, 9434.08) gs2 <- log(As2) arls0 <- round(XGRSR.arl(theta/2, gs2, 0, zr=-5, r=300, MPT=TRUE), digits=2) arls1 <- round(XGRSR.arl(theta/2, gs2, theta, zr=-5, r=300, MPT=TRUE), digits=2) data.frame(As2, arls0, arls1) ## Table 3 from Moustakides et al. (2009) ## original values are # gamma A ARL/E_infty(L) SADD/E_1(L) # 50 37.38 49.45 12.30 # 100 74.76 99.45 16.60 # 500 373.81 499.45 28.05 # 1000 747.62 999.45 33.33 # 5000 3738.08 4999.45 45.96 #10000 7476.15 9999.24 51.49 theta <- .5 As3 <- c(37.38, 74.76, 373.81, 747.62, 3738.08, 7476.15) gs3 <- log(As3) arls0 <- round(XGRSR.arl(theta/2, gs3, 0, zr=-5, r=70, MPT=TRUE), digits=2) arls1 <- round(XGRSR.arl(theta/2, gs3, theta, zr=-5, r=70, MPT=TRUE), digits=2) data.frame(As3, arls0, arls1) ## Table 4 from Moustakides et al. (2009) ## original values are # gamma A ARL/E_infty(L) SADD/E_1(L) # 50 28.02 49.78 4.98 # 100 56.04 99.79 6.22 # 500 280.19 499.79 9.30 # 1000 560.37 999.79 10.66 # 5000 2801.85 5000.93 13.86 #10000 5603.70 9999.87 15.24 theta <- 1 As4 <- c(28.02, 56.04, 280.19, 560.37, 2801.85, 5603.7) gs4 <- log(As4) arls0 <- round(XGRSR.arl(theta/2, gs4, 0, zr=-6, r=40, MPT=TRUE), digits=2) arls1 <- round(XGRSR.arl(theta/2, gs4, theta, zr=-6, r=40, MPT=TRUE), digits=2) data.frame(As4, arls0, arls1) } \keyword{ts} spc/man/scusum.crit.Rd0000644000175100001440000000516412273727245014417 0ustar hornikusers\name{scusum.crit} \alias{scusum.crit} \title{Compute decision intervals of CUSUM control charts (variance charts)} \description{omputation of the decision intervals (alarm limits) for different types of CUSUM control charts (based on the sample variance \eqn{S^2}) monitoring normal variance.} \usage{scusum.crit(k, L0, sigma, df, hs=0, sided="upper", mode="eq.tails", k2=NULL, hs2=0, r=40, qm=30)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{L0}{in-control ARL.} \item{sigma}{true standard deviation.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided CUSUM-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart), \code{"lower"} (lower chart), and \code{"two"} (two-sided chart), respectively. Note that for the two-sided chart the parameters \code{"k2"} and \code{"h2"} have to be set too.} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"eq.tails"} two one-sided CUSUM charts (lower and upper) with the same in-control ARL are coupled. With \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated).} \item{k2}{in case of a two-sided CUSUM chart for variance the reference value of the lower chart.} \item{hs2}{in case of a two-sided CUSUM chart for variance the headstart of the lower chart.} \item{r}{Dimension of the resulting linear equation system (highest order of the collocation polynomials times number of intervals -- see Knoth 2006).} \item{qm}{Number of quadrature nodes for calculating the collocation definite integrals.} } \details{ \code{scusum.crit} ddetermines the decision interval (alarm limit) for given in-control ARL \code{L0} by applying secant rule and using \code{scusum.arl()}.} \value{Returns a single value which resembles the decision interval \code{h}.} \references{ S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2006), Computation of the ARL for CUSUM-\eqn{S^2}{S^2} schemes, \emph{Computational Statistics & Data Analysis 51}, 499-512. } \author{Sven Knoth} \seealso{ \code{xcusum.arl} for zero-state ARL computation of CUSUM control charts monitoring normal mean. } \examples{ ## Knoth (2006) ## compare with Table 1 (p. 507) k <- 1.46 # sigma1 = 1.5 df <- 1 L0 <- 260.74 h <- scusum.crit(k, L0, 1, df) h # original value is 10 } \keyword{ts} spc/man/sewma.arl.Rd0000644000175100001440000000676712273740501014031 0ustar hornikusers\name{sewma.arl} \alias{sewma.arl} \title{Compute ARLs of EWMA control charts (variance charts)} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of EWMA control charts (based on the sample variance \eqn{S^2}) monitoring normal variance.} \usage{sewma.arl(l,cl,cu,sigma,df,s2.on=TRUE,hs=NULL,sided="upper",r=40,qm=30)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{cl}{lower control limit of the EWMA control chart.} \item{cu}{upper control limit of the EWMA control chart.} \item{sigma}{true standard deviation.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{s2.on}{distinguishes between \eqn{S^2}{S^2} and \eqn{S}{S} chart.} \item{hs}{so-called headstart (enables fast initial response); the default (\code{NULL}) yields the expected in-control value of \eqn{S^2}{S^2} (1) and \eqn{S}{S} (\eqn{c_4}{c_4}), respectively.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{r}{dimension of the resulting linear equation system (highest order of the collocation polynomials).} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} } \details{ \code{sewma.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of collocation (Chebyshev polynomials).} \value{Returns a single value which resembles the ARL.} \references{ S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2006), Computation of the ARL for CUSUM-\eqn{S^2}{S^2} schemes, \emph{Computational Statistics & Data Analysis 51}, 499-512. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL computation of EWMA control charts for monitoring normal mean. } \examples{ ## Knoth (2005) ## compare with Table 1 (p. 347): 249.9997 ## Monte Carlo with 10^9 replicates: 249.9892 +/- 0.008 l <- .025 df <- 1 cu <- 1 + 1.661865*sqrt(l/(2-l))*sqrt(2/df) sewma.arl(l,0,cu,1,df) ## ARL values for upper and lower EWMA charts with reflecting barriers ## (reflection at in-control level sigma0 = 1) ## examples from Knoth (2006), Tables 4 and 5 Ssewma.arl <- Vectorize("sewma.arl", "sigma") ## upper chart with reflection at sigma0=1 in Table 4 ## original entries are # sigma ARL # 1 100.0 # 1.01 85.3 # 1.02 73.4 # 1.03 63.5 # 1.04 55.4 # 1.05 48.7 # 1.1 27.9 # 1.2 12.9 # 1.3 7.86 # 1.4 5.57 # 1.5 4.30 # 2 2.11 \dontrun{ l <- 0.15 df <- 4 cu <- 1 + 2.4831*sqrt(l/(2-l))*sqrt(2/df) sigmas <- c(1 + (0:5)/100, 1 + (1:5)/10, 2) arls <- round(Ssewma.arl(l, 1, cu, sigmas, df, sided="Rupper", r=100), digits=2) data.frame(sigmas, arls)} ## lower chart with reflection at sigma0=1 in Table 5 ## original entries are # sigma ARL # 1 200.04 # 0.9 38.47 # 0.8 14.63 # 0.7 8.65 # 0.6 6.31 \dontrun{ l <- 0.115 df <- 5 cl <- 1 - 2.0613*sqrt(l/(2-l))*sqrt(2/df) sigmas <- c((10:6)/10) arls <- round(Ssewma.arl(l, cl, 1, sigmas, df, sided="Rlower", r=100), digits=2) data.frame(sigmas, arls)} } \keyword{ts} spc/man/xDewma.arl.Rd0000644000175100001440000002253712274007616014137 0ustar hornikusers\name{xDewma.arl} \alias{xDewma.arl} \title{Compute ARLs of EWMA control charts under drift} \description{Computation of the (zero-state and other) Average Run Length (ARL) under drift for different types of EWMA control charts monitoring normal mean.} \usage{xDewma.arl(l, c, delta, zr = 0, hs = 0, sided = "one", limits = "fix", mode = "Gan", m = NULL, q = 1, r = 40, with0 = FALSE)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{delta}{true drift parameter.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguish between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different control limits behavior.} \item{mode}{decide whether Gan's or Knoth's approach is used. Use \code{"Gan"} and \code{"Knoth"}, respectively.} \item{m}{parameter used if \code{mode="Gan"}. \code{m} is design parameter of Gan's approach. If \code{m=NULL}, then \code{m} will increased until the resulting ARL does not change anymore.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\geq)}, will be determined. Note that mu0=0 is implicitely fixed. Deploy large \code{q} to mimic steady-state. It works only for \code{mode="Knoth"}.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} \item{with0}{defines whether the first observation used for the RL calculation follows already 1*delta or still 0*delta. With \code{q} additional flexibility is given.} } \details{ Based on Gan (1991) or Knoth (2003), the ARL is calculated for EWMA control charts under drift. In case of Gan's framework, the usual ARL function with mu=m*delta is determined and recursively via m-1, m-2, ... 1 (or 0) the drift ARL determined. The framework of Knoth allows to calculate ARLs for varying parameters, such as control limits and distributional parameters. For details see the cited papers. } \value{Returns a single value which resembles the ARL.} \references{ F. F. Gan (1991), EWMA control chart under linear drift, \emph{J. Stat. Comput. Simulation 38}, 181-200. L. A. Aerne, C. W. Champ and S. E. Rigdon (1991), Evaluation of control charts under linear trend, \emph{Commun. Stat., Theory Methods 20}, 3341-3349. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. H. M. Fahmy and E. A. Elsayed (2006), Detection of linear trends in process mean, \emph{International Journal of Production Research 44}, 487-504. S. Knoth (2012), More on Control Charting under Drift, in: \emph{Frontiers in Statistical Quality Control 10}, H.-J. Lenz, W. Schmid and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 53-68. C. Zou, Y. Liu and Z. Wang (2009), Comparisons of control schemes for monitoring the means of processes subject to drifts, \emph{Metrika 70}, 141-163. } \author{Sven Knoth} \seealso{ \code{xewma.arl} and \code{xewma.ad} for zero-state and steady-state ARL computation of EWMA control charts for the classical step change model. } \examples{ \dontrun{ DxDewma.arl <- Vectorize(xDewma.arl, "delta") ## Gan (1991) ## Table 1 ## original values are # delta arlE1 arlE2 arlE3 # 0 500 500 500 # 0.0001 482 460 424 # 0.0010 289 231 185 # 0.0020 210 162 129 # 0.0050 126 94.6 77.9 # 0.0100 81.7 61.3 52.7 # 0.0500 27.5 21.8 21.9 # 0.1000 17.0 14.2 15.3 # 1.0000 4.09 4.28 5.25 # 3.0000 2.60 2.90 3.43 # lambda1 <- 0.676 lambda2 <- 0.242 lambda3 <- 0.047 h1 <- 2.204/sqrt(lambda1/(2-lambda1)) h2 <- 1.111/sqrt(lambda2/(2-lambda2)) h3 <- 0.403/sqrt(lambda3/(2-lambda3)) deltas <- c(.0001, .001, .002, .005, .01, .05, .1, 1, 3) arlE10 <- round(xewma.arl(lambda1, h1, 0, sided="two"), digits=2) arlE1 <- c(arlE10, round(DxDewma.arl(lambda1, h1, deltas, sided="two", with0=TRUE), digits=2)) arlE20 <- round(xewma.arl(lambda2, h2, 0, sided="two"), digits=2) arlE2 <- c(arlE20, round(DxDewma.arl(lambda2, h2, deltas, sided="two", with0=TRUE), digits=2)) arlE30 <- round(xewma.arl(lambda3, h3, 0, sided="two"), digits=2) arlE3 <- c(arlE30, round(DxDewma.arl(lambda3, h3, deltas, sided="two", with0=TRUE), digits=2)) data.frame(delta=c(0, deltas), arlE1, arlE2, arlE3) ## do the same with more digits for the alarm threshold L0 <- 500 h1 <- xewma.crit(lambda1, L0, sided="two") h2 <- xewma.crit(lambda2, L0, sided="two") h3 <- xewma.crit(lambda3, L0, sided="two") lambdas <- c(lambda1, lambda2, lambda3) hs <- c(h1, h2, h3) * sqrt(lambdas/(2-lambdas)) hs # compare with Gan's values 2.204, 1.111, 0.403 round(hs, digits=3) arlE10 <- round(xewma.arl(lambda1, h1, 0, sided="two"), digits=2) arlE1 <- c(arlE10, round(DxDewma.arl(lambda1, h1, deltas, sided="two", with0=TRUE), digits=2)) arlE20 <- round(xewma.arl(lambda2, h2, 0, sided="two"), digits=2) arlE2 <- c(arlE20, round(DxDewma.arl(lambda2, h2, deltas, sided="two", with0=TRUE), digits=2)) arlE30 <- round(xewma.arl(lambda3, h3, 0, sided="two"), digits=2) arlE3 <- c(arlE30, round(DxDewma.arl(lambda3, h3, deltas, sided="two", with0=TRUE), digits=2)) data.frame(delta=c(0, deltas), arlE1, arlE2, arlE3) ## Aerne et al. (1991) -- two-sided EWMA ## Table I (continued) ## original numbers are # delta arlE1 arlE2 arlE3 # 0.000000 465.0 465.0 465.0 # 0.005623 77.01 85.93 102.68 # 0.007499 64.61 71.78 85.74 # 0.010000 54.20 59.74 71.22 # 0.013335 45.20 49.58 58.90 # 0.017783 37.76 41.06 48.54 # 0.023714 31.54 33.95 39.87 # 0.031623 26.36 28.06 32.68 # 0.042170 22.06 23.19 26.73 # 0.056234 18.49 19.17 21.84 # 0.074989 15.53 15.87 17.83 # 0.100000 13.07 13.16 14.55 # 0.133352 11.03 10.94 11.88 # 0.177828 9.33 9.12 9.71 # 0.237137 7.91 7.62 7.95 # 0.316228 6.72 6.39 6.52 # 0.421697 5.72 5.38 5.37 # 0.562341 4.88 4.54 4.44 # 0.749894 4.18 3.84 3.68 # 1.000000 3.58 3.27 3.07 # lambda1 <- .133 lambda2 <- .25 lambda3 <- .5 cE1 <- 2.856 cE2 <- 2.974 cE3 <- 3.049 deltas <- 10^(-(18:0)/8) arlE10 <- round(xewma.arl(lambda1, cE1, 0, sided="two"), digits=2) arlE1 <- c(arlE10, round(DxDewma.arl(lambda1, cE1, deltas, sided="two"), digits=2)) arlE20 <- round(xewma.arl(lambda2, cE2, 0, sided="two"), digits=2) arlE2 <- c(arlE20, round(DxDewma.arl(lambda2, cE2, deltas, sided="two"), digits=2)) arlE30 <- round(xewma.arl(lambda3, cE3, 0, sided="two"), digits=2) arlE3 <- c(arlE30, round(DxDewma.arl(lambda3, cE3, deltas, sided="two"), digits=2)) data.frame(delta=c(0, round(deltas, digits=6)), arlE1, arlE2, arlE3) ## Fahmy/Elsayed (2006) -- two-sided EWMA ## Table 4 (Monte Carlo results, 10^4 replicates, change point at t=51!) ## original numbers are # delta arl s.e. # 0.00 365.749 3.598 # 0.10 12.971 0.029 # 0.25 7.738 0.015 # 0.50 5.312 0.009 # 0.75 4.279 0.007 # 1.00 3.680 0.006 # 1.25 3.271 0.006 # 1.50 2.979 0.005 # 1.75 2.782 0.004 # 2.00 2.598 0.005 # lambda <- 0.1 cE <- 2.7 deltas <- c(.1, (1:8)/4) arlE1 <- c(round(xewma.arl(lambda, cE, 0, sided="two"), digits=3), round(DxDewma.arl(lambda, cE, deltas, sided="two"), digits=3)) arlE51 <- c(round(xewma.arl(lambda, cE, 0, sided="two", q=51)[51], digits=3), round(DxDewma.arl(lambda, cE, deltas, sided="two", mode="Knoth", q=51), digits=3)) data.frame(delta=c(0, deltas), arlE1, arlE51) ## additional Monte Carlo results with 10^8 replicates # delta arl.q=1 s.e. arl.q=51 s.e. # 0.00 368.910 0.036 361.714 0.038 # 0.10 12.986 0.000 12.781 0.000 # 0.25 7.758 0.000 7.637 0.000 # 0.50 5.318 0.000 5.235 0.000 # 0.75 4.285 0.000 4.218 0.000 # 1.00 3.688 0.000 3.628 0.000 # 1.25 3.274 0.000 3.233 0.000 # 1.50 2.993 0.000 2.942 0.000 # 1.75 2.808 0.000 2.723 0.000 # 2.00 2.616 0.000 2.554 0.000 ## Zou et al. (2009) -- one-sided EWMA ## Table 1 ## original values are # delta arl1 arl2 arl3 # 0 ~ 1730 # 0.0005 317 377 440 # 0.001 215 253 297 # 0.005 83.6 92.6 106 # 0.01 55.6 58.8 66.1 # 0.05 22.6 21.1 22.0 # 0.1 15.5 13.9 13.8 # 0.5 6.65 5.56 5.09 # 1.0 4.67 3.83 3.43 # 2.0 3.21 2.74 2.32 # 3.0 2.86 2.06 1.98 # 4.0 2.14 2.00 1.83 l1 <- 0.03479 l2 <- 0.11125 l3 <- 0.23052 c1 <- 2.711 c2 <- 3.033 c3 <- 3.161 zr <- -6 r <- 50 deltas <- c(0.0005, 0.001, 0.005, 0.01, 0.05, 0.1, 0.5, 1:4) arl1 <- c(round(xewma.arl(l1, c1, 0, zr=zr, r=r), digits=2), round(DxDewma.arl(l1, c1, deltas, zr=zr, r=r), digits=2)) arl2 <- c(round(xewma.arl(l2, c2, 0, zr=zr), digits=2), round(DxDewma.arl(l2, c2, deltas, zr=zr, r=r), digits=2)) arl3 <- c(round(xewma.arl(l3, c3, 0, zr=zr, r=r), digits=2), round(DxDewma.arl(l3, c3, deltas, zr=zr, r=r), digits=2)) data.frame(delta=c(0, deltas), arl1, arl2, arl3) } } \keyword{ts} spc/man/scusum.arl.Rd0000644000175100001440000000620712274011636014222 0ustar hornikusers\name{scusum.arl} \alias{scusum.arl} \title{Compute ARLs of CUSUM control charts (variance charts)} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of CUSUM control charts (based on the sample variance \eqn{S^2}) monitoring normal variance.} \usage{scusum.arl(k, h, sigma, df, hs=0, sided="upper", k2=NULL, h2=NULL, hs2=0, r=40, qm=30, version=2)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.} \item{sigma}{true standard deviation.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided CUSUM-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart), \code{"lower"} (lower chart), and \code{"two"} (two-sided chart), respectively. Note that for the two-sided chart the parameters \code{"k2"} and \code{"h2"} have to be set too.} \item{k2}{In case of a two-sided CUSUM chart for variance the reference value of the lower chart.} \item{h2}{In case of a two-sided CUSUM chart for variance the decision interval of the lower chart.} \item{hs2}{In case of a two-sided CUSUM chart for variance the headstart of the lower chart.} \item{r}{Dimension of the resulting linear equation system (highest order of the collocation polynomials times number of intervals -- see Knoth 2006).} \item{qm}{Number of quadrature nodes for calculating the collocation definite integrals.} \item{version}{Distinguish version numbers (1,2,...). For internal use only.} } \details{ \code{scusum.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of collocation (piecewise Chebyshev polynomials).} \value{Returns a single value which resembles the ARL.} \references{ S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2006), Computation of the ARL for CUSUM-\eqn{S^2}{S^2} schemes, \emph{Computational Statistics & Data Analysis 51}, 499-512. } \author{Sven Knoth} \seealso{ \code{xcusum.arl} for zero-state ARL computation of CUSUM control charts for monitoring normal mean. } \examples{ ## Knoth (2006) ## compare with Table 1 (p. 507) k <- 1.46 # sigma1 = 1.5 df <- 1 h <- 10 # original values # sigma coll63 BE Hawkins MC 10^9 (s.e.) # 1 260.7369 260.7546 261.32 260.7399 (0.0081) # 1.1 90.1319 90.1389 90.31 90.1319 (0.0027) # 1.2 43.6867 43.6897 43.75 43.6845 (0.0013) # 1.3 26.2916 26.2932 26.32 26.2929 (0.0007) # 1.4 18.1231 18.1239 18.14 18.1235 (0.0005) # 1.5 13.6268 13.6273 13.64 13.6272 (0.0003) # 2 5.9904 5.9910 5.99 5.9903 (0.0001) # replicate the column coll63 sigma <- c(1, 1.1, 1.2, 1.3, 1.4, 1.5, 2) arl <- rep(NA, length(sigma)) for ( i in 1:length(sigma) ) arl[i] <- round(scusum.arl(k, h, sigma[i], df, r=63, qm=20, version=2), digits=4) data.frame(sigma, arl) } \keyword{ts} spc/man/xtewma.arl.Rd0000644000175100001440000000674112615440107014211 0ustar hornikusers\name{xtewma.arl} \alias{xtewma.arl} \title{Compute ARLs of EWMA control charts, t distributed data} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of EWMA control charts monitoring the mean of t distributed data.} \usage{xtewma.arl(l,c,df,mu,zr=0,hs=0,sided="two",limits="fix",mode="tan",q=1,r=40)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{df}{degrees of freedom -- parameter of the t distribution.} \item{mu}{true mean.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different control limits behavior.} \item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently, \code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\ge q)}, will be determined. Note that mu0=0 is implicitely fixed.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} } \details{ In case of the EWMA chart with fixed control limits, \code{xtewma.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature. If \code{limits} is \code{"vacl"}, then the method presented in Knoth (2003) is utilized. Other values (normal case) for \code{limits} are not yet supported. } \value{Except for the fixed limits EWMA charts it returns a single value which resembles the ARL. For fixed limits charts, it returns a vector of length \code{q} which resembles the ARL and the sequence of conditional expected delays for \code{q}=1 and \code{q}>1, respectively.} \references{ K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. S. V. Crowder (1987), A simple method for studying run-length distributions of exponentially weighted moving average charts, \emph{Technometrics 29}, 401-407. J. M. Lucas and M. S. Saccucci (1990), Exponentially weighted moving average control schemes: Properties and enhancements, \emph{Technometrics 32}, 1-12. C. M. Borror, D. C. Montgomery, and G. C. Runger (1999), Robustness of the EWMA control chart to non-normality , \emph{Journal of Quality Technology 31}, 309-316. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL computation of EWMA control charts in the normal case. } \examples{ ## Borror/Montgomery/Runger (1999), Table 3 lambda <- 0.1 cE <- 2.703 df <- c(4, 6, 8, 10, 15, 20, 30, 40, 50) L0 <- rep(NA, length(df)) for ( i in 1:length(df) ) { L0[i] <- round(xtewma.arl(lambda, cE*sqrt(df[i]/(df[i]-2)), df[i], 0), digits=0) } data.frame(df, L0) } \keyword{ts} spc/man/p.ewma.arl.Rd0000644000175100001440000000517512274004530014070 0ustar hornikusers\name{p.ewma.arl} \alias{p.ewma.arl} \title{Compute ARLs of binomial EWMA p control charts} \description{Computation of the (zero-state) Average Run Length (ARL) at given rate \code{p}.} \usage{p.ewma.arl(lambda, ucl, n, p, z0, d.res=1, r.mode="ieee.round", i.mode="integer")} \arguments{ \item{lambda}{smoothing parameter of the EWMA p control chart.} \item{ucl}{upper control limit of the EWMA p control chart.} \item{n}{subgroup size.} \item{p}{(failure/success) rate.} \item{z0}{so-called headstart (give fast initial response).} \item{d.res}{resolution (see details).} \item{r.mode}{round mode -- allowed modes are \code{"gan.floor"}, \code{"floor"}, \code{"ceil"}, \code{"ieee.round"}, \code{"round"}, \code{"mix"}.} \item{i.mode}{type of interval center -- \code{"integer"} or \code{"half"} integer.} } \details{ The monitored data follow a binomial distribution with size \code{n} and failure/success probability \code{p}. The ARL values of the resulting EWMA control chart are determined by Markov chain approximation. Here, the original EWMA values are approximated by multiples of one over \code{d.res}. Different ways of rounding (see \code{r.mode}) to the next multiple are implemented. Besides Gan's paper nothing is published about the numerical subtleties. } \value{Return single value which resemble the ARL.} \references{ F. F. Gan (1990), Monitoring observations generated from a binomial distribution using modified exponentially weighted moving average control chart, \emph{J. Stat. Comput. Simulation} 37, 45-60. S. Knoth and S. Steinmetz (2013), EWMA \code{p} charts under sampling by variables, \emph{International Journal of Production Research} 51, 3795-3807. } \author{Sven Knoth} \seealso{later.} \examples{ ## Gan (1990) # Table 1 n <- 150 p0 <- .1 z0 <- n*p0 lambda <- c(1, .51, .165) hu <- c(27, 22, 18) p.value <- .1 + (0:20)/200 p.EWMA.arl <- Vectorize(p.ewma.arl, "p") arl1.value <- round(p.EWMA.arl(lambda[1], hu[1], n, p.value, z0, r.mode="round"), digits=2) arl2.value <- round(p.EWMA.arl(lambda[2], hu[2], n, p.value, z0, r.mode="round"), digits=2) arl3.value <- round(p.EWMA.arl(lambda[3], hu[3], n, p.value, z0, r.mode="round"), digits=2) arls <- matrix(c(arl1.value, arl2.value, arl3.value), ncol=length(lambda)) rownames(arls) <- p.value colnames(arls) <- paste("lambda =", lambda) arls ## Knoth/Steinmetz (2013) n <- 5 p0 <- 0.02 z0 <- n*p0 lambda <- 0.3 ucl <- 0.649169922 ## in-control ARL 370.4 (determined with d.res = 2^14 = 16384) res.list <- 2^(1:12) arl.list <- NULL for ( res in res.list ) { arl <- p.ewma.arl(lambda, ucl, n, p0, z0, d.res=res) arl.list <- c(arl.list, arl) } cbind(res.list, arl.list) } \keyword{ts} spc/man/sewma.sf.Rd0000644000175100001440000000444612273730504013655 0ustar hornikusers\name{sewma.sf} \alias{sewma.sf} \title{Compute the survival function of EWMA run length} \description{Computation of the survival function of the Run Length (RL) for EWMA control charts monitoring normal variance.} \usage{sewma.sf(n, l, cl, cu, sigma, df, hs=1, sided="upper", r=40, qm=30)} \arguments{ \item{n}{calculate sf up to value \code{n}.} \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{cl}{lower control limit of the EWMA control chart.} \item{cu}{upper control limit of the EWMA control chart.} \item{sigma}{true standard deviation.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{r}{dimension of the resulting linear equation system (highest order of the collocation polynomials).} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} } \details{ The survival function P(L>n) and derived from it also the cdf P(L<=n) and the pmf P(L=n) illustrate the distribution of the EWMA run length. For large n the geometric tail could be exploited. That is, with reasonable large n the complete distribution is characterized. The algorithm is based on Waldmann's survival function iteration procedure and on results in Knoth (2007). } \value{Returns a vector which resembles the survival function up to a certain point.} \references{ S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{sewma.arl} for zero-state ARL computation of variance EWMA control charts. } \examples{ ## Knoth (2014?) } \keyword{ts} spc/man/xsewma.crit.Rd0000644000175100001440000000726412273731437014405 0ustar hornikusers\name{xsewma.crit} \alias{xsewma.crit} \title{Compute critical values of simultaneous EWMA control charts (mean and variance charts)} \description{Computation of the critical values (similar to alarm limits) for different types of simultaneous EWMA control charts (based on the sample mean and the sample variance \eqn{S^2}) monitoring normal mean and variance.} \usage{xsewma.crit(lx, ls, L0, df, mu0=0, sigma0=1, cu=NULL, hsx=0, hss=1, s2.on=TRUE, sided="upper", mode="fixed", Nx=30, Ns=40, qm=30)} \arguments{ \item{lx}{smoothing parameter lambda of the two-sided mean EWMA chart.} \item{ls}{smoothing parameter lambda of the variance EWMA chart.} \item{L0}{in-control ARL.} \item{mu0}{in-control mean.} \item{sigma0}{in-control standard deviation.} \item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit (\code{mode}=\code{"fixed"}) a value larger than \code{sigma0} has to been given, for all other cases \code{cu} is ignored.} \item{hsx}{so-called headstart (enables fast initial response) of the mean chart -- do not confuse with the true FIR feature considered in xewma.arl; will be updated.} \item{hss}{headstart (enables fast initial response) of the variance chart.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{s2.on}{distinguishes between \eqn{S^2}{S^2} and \eqn{S}{S} chart.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit (see \code{cu}) is set and only the lower is determined to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated).} \item{Nx}{dimension of the approximating matrix of the mean chart.} \item{Ns}{dimension of the approximating matrix of the variance chart.} \item{qm}{number of quadrature nodes used for the collocation integrals.} } \details{ \code{xsewma.crit} determines the critical values (similar to alarm limits) for given in-control ARL \code{L0} by applying secant rule and using \code{xsewma.arl()}. In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"} a two-dimensional secant rule is applied that also ensures that the maximum of the ARL function for given standard deviation is attained at \code{sigma0}. See Knoth (2007) for details and application. } \value{Returns the critical value of the two-sided mean EWMA chart and the lower and upper controls limit \code{cl} and \code{cu} of the variance EWMA chart.} \references{ S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. } \author{Sven Knoth} \seealso{\code{xsewma.arl} for calculation of ARL of simultaneous EWMA charts.} \examples{ ## Knoth (2007) ## results in Table 2 # subgroup size n=5, df=n-1 df <- 4 # lambda of mean chart lx <- .134 # lambda of variance chart ls <- .1 # in-control ARL L0 <- 252.3 # matrix dimensions for mean and variance part Nx <- 25 Ns <- 25 # mode of variance chart SIDED <- "upper" crit <- xsewma.crit(lx, ls, L0, df, sided=SIDED, Nx=Nx, Ns=Ns) crit ## output as used in Knoth (2007) crit["cx"]/sqrt(df+1)*sqrt(lx/(2-lx)) crit["cu"] - 1 } \keyword{ts} spc/man/xtcusum.arl.Rd0000644000175100001440000000451112553223203014402 0ustar hornikusers\name{xtcusum.arl} \alias{xtcusum.arl} \title{Compute ARLs of CUSUM control charts} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of CUSUM control charts monitoring normal mean.} \usage{xtcusum.arl(k, h, df, mu, hs = 0, sided="one", mode="tan", r=30)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.} \item{df}{degrees of freedom -- parameter of the t distribution.} \item{mu}{true mean.} \item{hs}{so-called headstart (give fast initial response).} \item{sided}{distinguish between one- and two-sided CUSUM schemes by choosing \code{"one"} and \code{"two"}, respectively.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1}.} \item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently, \code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.} } \details{ \code{xtcusum.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature. } \value{Returns a single value which resembles the ARL.} \references{ A. L. Goel, S. M. Wu (1971), Determination of A.R.L. and a contour nomogram for CUSUM charts to control normal mean, \emph{Technometrics 13}, 221-230. D. Brook, D. A. Evans (1972), An approach to the probability distribution of cusum run length, \emph{Biometrika 59}, 539-548. J. M. Lucas, R. B. Crosier (1982), Fast initial response for cusum quality-control schemes: Give your cusum a headstart, \emph{Technometrics 24}, 199-205. L. C. Vance (1986), Average run lengths of cumulative sum control charts for controlling normal means, \emph{Journal of Quality Technology 18}, 189-193. K.-H. Waldmann (1986), Bounds for the distribution of the run length of one-sided and two-sided CUSUM quality control schemes, \emph{Technometrics 28}, 61-67. R. B. Crosier (1986), A new two-sided cumulative quality control scheme, \emph{Technometrics 28}, 187-194. } \author{Sven Knoth} \seealso{ \code{xtewma.arl} for zero-state ARL computation of EWMA control charts and \code{xtcusum.arl} for the zero-state ARL of CUSUM for normal data. } \examples{ ## will follow } \keyword{ts} spc/man/xcusum.crit.L0h.Rd0000644000175100001440000000343012273662757015046 0ustar hornikusers\name{xcusum.crit.L0h} \alias{xcusum.crit.L0h} \title{Compute the CUSUM reference value k for given in-control ARL and threshold h} \description{Computation of the reference value k for one-sided CUSUM control charts monitoring normal mean, if the in-control ARL L0 and the alarm threshold h are given.} \usage{xcusum.crit.L0h(L0, h, hs=0, sided="one", r=30, L0.eps=1e-6, k.eps=1e-8)} \arguments{ \item{L0}{in-control ARL.} \item{h}{alarm level of the CUSUM control chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one-, two-sided and Crosier's modified two-sided CUSUM scheme choosing \code{"one"}, \code{"two"}, and \code{"Crosier"}, respectively.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-, two-sided) or \code{2r+1} (Crosier).} \item{L0.eps}{error bound for the L0 error.} \item{k.eps}{bound for the difference of two successive values of k.} } \details{ \code{xcusum.crit.L0h} determines the reference value k for given in-control ARL \code{L0} and alarm level \code{h} by applying secant rule and using \code{xcusum.arl()}. Note that not for any combination of \code{L0} and \code{h} a solution exists -- for given \code{L0} there is a maximal value for \code{h} to get a valid result \code{k}. } \value{Returns a single value which resembles the reference value \code{k}.} %\references{Later...} \author{Sven Knoth} \seealso{\code{xcusum.arl} for zero-state ARL computation.} \examples{ L0 <- 100 h.max <- xcusum.crit(0, L0, 0) hs <- (300:1)/100 hs <- hs[hs < h.max] ks <- NULL for ( h in hs ) ks <- c(ks, xcusum.crit.L0h(L0, h)) k.max <- qnorm( 1 - 1/L0 ) plot(hs, ks, type="l", ylim=c(0, max(k.max, ks)), xlab="h", ylab="k") abline(h=c(0, k.max), col="red") } \keyword{ts} spc/man/tol.lim.fact.Rd0000644000175100001440000000476012274006431014417 0ustar hornikusers\name{tol.lim.fac} \alias{tol.lim.fac} \title{Two-sided tolerance limit factors} \description{For constructing tolerance intervals, which cover a given proportion \eqn{p}{p} of a normal distribution with unknown mean and variance with confidence \eqn{1-\alpha}{1-a}, one needs to calculate the so-called tolerance limit factors \eqn{k}{k}. These values are computed for a given sample size \eqn{n}{n}.} \usage{tol.lim.fac(n,p,a,mode="WW",m=30)} \arguments{ \item{n}{sample size.} \item{p}{coverage.} \item{a}{error probability \eqn{\alpha}{a}, resulting interval covers at least proportion \code{p} with confidence of at least \eqn{1-\alpha}{1-a}.} \item{mode}{distinguish between Wald/Wolfowitz' approximation method (\code{"WW"}) and the more accurate approach (\code{"exact"}) based on Gauss-Legendre quadrature.} \item{m}{number of abscissas for the quadrature (needed only for \code{method="exact"}), of course, the larger the more accurate.} } \details{ \code{tol.lim.fac} determines tolerance limits factors \eqn{k}{k} by means of the fast and simple approximation due to Wald/Wolfowitz (1946) and of Gauss-Legendre quadrature like Odeh/Owen (1980), respectively, who used in fact the Simpson Rule. Then, by \eqn{\bar x \pm k \cdot s}{xbar +- k s} one can build the tolerance intervals which cover at least proportion \eqn{p}{p} of a normal distribution for given confidence level of \eqn{1-\alpha}{1-a}. \eqn{\bar x}{xbar} and \eqn{s}{s} stand for the sample mean and the sample standard deviation, respectively.} \value{Returns a single value which resembles the tolerance limit factor.} \references{ A. Wald, J. Wolfowitz (1946), Tolerance limits for a normal distribution, \emph{Annals of Mathematical Statistics 17}, 208-215. R. E. Odeh, D. B. Owen (1980), \emph{Tables for Normal Tolerance Limits}, Sampling Plans, and Screening, Marcel Dekker, New York. } \author{Sven Knoth} \seealso{ \code{qnorm} for the ''asymptotic'' case -- cf. second example. } \examples{ n <- 2:10 p <- .95 a <- .05 kWW <- sapply(n,p=p,a=a,tol.lim.fac) kEX <- sapply(n,p=p,a=a,mode="exact",tol.lim.fac) print(cbind(n,kWW,kEX),digits=4) ## Odeh/Owen (1980), page 98, in Table 3.4.1 ## n factor k ## 2 36.519 ## 3 9.789 ## 4 6.341 ## 5 5.077 ## 6 4.422 ## 7 4.020 ## 8 3.746 ## 9 3.546 ## 10 3.393 ## n -> infty n <- 10^{1:7} p <- .95 a <- .05 kEX <- round(sapply(n,p=p,a=a,mode="exact",tol.lim.fac),digits=4) kEXinf <- round(qnorm(1-a/2),digits=4) print(rbind(cbind(n,kEX),c("infinity",kEXinf)),quote=FALSE) } \keyword{ts}