spc/0000755000176000001440000000000012044761316011073 5ustar ripleyusersspc/MD50000644000176000001440000001170612044761316011410 0ustar ripleyusers7d4c7de8240d2b58eb3bf61cbf4600da *DESCRIPTION 49732e69c954a584db395fecad75430f *NAMESPACE 086bea677bfa69d34d721ca739b8387f *R/p.ewma.arl.R 6718cda24a49a13852f43ad0cd92fc0b *R/phat.ewma.arl.R 4563680fc3e91a6204d7e6ba25660bd4 *R/phat.ewma.crit.R 40bc6ee8dafa1c65396079f922663e3f *R/phat.ewma.lambda.R 317e34aaffbe5a167d6f84b92b225dc1 *R/s.res.ewma.arl.R af70124f89b8cb5a31d5e859ce4c05da *R/sewma.arl.R 5905a53469c23154ad142acca32243db *R/sewma.crit.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 9ea292236ae925a2346c2fb1a4b0d6ba *R/xcusum.arl.R 3ece9667f05deb05a7ecf3bff05bec59 *R/xcusum.crit.L0L1.R 159d295a0d1998df9504da0a0a820fde *R/xcusum.crit.L0h.R dc00420d8558cd9aa8a72799d57792ec *R/xcusum.crit.R 170432e0c62842d7994e82898371a09f *R/xcusum.q.R 185c396ccf056bd67841612b7db5c376 *R/xcusum.sf.R 628fd3402d8c106ba1dbd25da316f983 *R/xewma.ad.R 429280e5396f535f8fe3b6ada25d1dee *R/xewma.arl.R 3fe56be97fa654f81d759f0fca68d0fa *R/xewma.crit.R 9c4a4557abf41bd3ab73093f5d35f2f9 *R/xewma.q.R dd5cd4324420f5823334883f5a1095aa *R/xewma.sf.R 27201ddd1f09320a16eb7c06716e1a2e *R/xgrsr.ad.R 9fbc666034b1bf6719a4055dfc1976bc *R/xgrsr.arl.R 28566d3276a419474104a437a6e6b481 *R/xgrsr.crit.R 30199f064e29b335f1cf70fb054d148b *R/xs.res.ewma.arl.R 48049b56879a2d94d06d60ad44a2f440 *R/xs.res.ewma.pms.R cbe0b1a230cf7f2dc3c2e100765ed8ea *R/xsewma.arl.R f2f0b5fa34169981c5823b8fb09c25dd *R/xsewma.crit.R 24bbe9df9f8a6abe6c497ed01a17d397 *R/xshewhartrunsrules.ad.R 4facffeca81aa3f9ac0f2b9e8089902d *R/xshewhartrunsrules.arl.R 6301fa5dedf8ba0804e7a03914836094 *R/xshewhartrunsrules.crit.R 886226d03f84cfbcef6d779d76df6c1b *R/xshewhartrunsrules.matrix.R c12aa60a1c2770c6622007043594dc58 *man/p.ewma.arl.Rd d363db215b9cca22fd787eb4eb199694 *man/phat.ewma.arl.Rd c352c2fdaf2fb41b29bec583cbdf5b45 *man/sewma.arl.Rd 5a0ba5a29a3910b71f4df938eafec17a *man/sewma.crit.Rd c515cdc45b13fd6e18bb5605ac5510c7 *man/tol.lim.fact.Rd 8cc9f37dd19bd4808484185457311bcf *man/xDcusum.arl.Rd 8b8982a05ba7208b305d9410d8b6192c *man/xDewma.arl.Rd cb19ae1fd5b5256d4fdac77c4a683d29 *man/xDgrsr.arl.Rd 3f76e874abeab6a1d5b797353d80b0ba *man/xDshewhartrunsrules.arl.Rd c6364ba0d27305c53a5f9726e21cb9ba *man/xcusum.ad.Rd 2fb762d3d9a246bd2c8b3a6ad44288cf *man/xcusum.arl.Rd dc5793210fec73e88faaf44731366f4d *man/xcusum.crit.L0L1.Rd 70e126b49d47c1c4148cc5c83ed97157 *man/xcusum.crit.L0h.Rd 4e4eff857989ec3db93d83ea60c013ad *man/xcusum.crit.Rd 01e43765289fe0ee7b08ee3fcd83c67e *man/xcusum.q.Rd 08f2cec21bdf235a8c7ffb5981930203 *man/xcusum.sf.Rd ab54c24ca02de4ed55cbc81d5053b5d6 *man/xewma.ad.Rd 4fada734580427108ce5c1def71b9be2 *man/xewma.arl.Rd b4138765aae313c0febf5058939bb9d8 *man/xewma.crit.Rd 860e557c56a2755f977c2a5ddb5eb9a5 *man/xewma.q.Rd 6923c2031a1f682610797f88c9beaf26 *man/xewma.sf.Rd d88111b44e7630472cf39375e594221d *man/xgrsr.ad.Rd c979b633ae8767a079a27257b76ddd73 *man/xgrsr.arl.Rd bf81be60e4b6a0d9ffe7195bdb382536 *man/xgrsr.crit.Rd 48b0f0a937de08af3505b1fe478b64fe *man/xsewma.arl.Rd 92b4f77d0ad59d3a2d85383cb7672fb2 *man/xsewma.crit.Rd c4a5ce003421597f181f44fded11fe3e *man/xshewhartrunsrules.arl.Rd 539763811a587934748f4bcecddc834f *man/xsresewma.arl.Rd 468c65a5b3746cd4a5abd6adf3498653 *src/allspc.c 7f3ebbeabd48d8d15b5155cb2d627b45 *src/ewma_p_arl_be.c 00533b5f868160fd7996f59278ffdbde *src/ewma_phat_arl_coll.c 6b628dfb36ba4c31ad0b7be022b7064c *src/ewma_phat_crit_coll.c f386749bf39728efe559b6faf5c358cf *src/ewma_phat_lambda_coll.c 55212f18aabbc265376a054e034c6c8e *src/sewma_arl.c 6782dd3a35eaaabdbacc23760244da05 *src/sewma_crit.c dfa00954609e5b3a509a286ed48501e3 *src/sewma_res_arl.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 20ef1db2d6511312e8a344c325ce9292 *src/xcusum_arl.c eeb348dfb7c4f3b49786d5c77a56029a *src/xcusum_crit.c 5159145d823621d789a60d0f9afcd8f0 *src/xcusum_q.c 1cecc337c63e314c2e390886d73dd17b *src/xcusum_sf.c 1b3a778d987cf1833c3dbdbe9f0acf0c *src/xewma_ad.c 90e2db71da5a7fdeb2179f268cfd36e7 *src/xewma_arl.c 924e49d6f154bc51d6e70083c531a661 *src/xewma_crit.c cdc327d7317afbf9b47f74a3a20c5e57 *src/xewma_q.c 901a9013eafee36e06a00884b00e73d9 *src/xewma_res_arl.c acfe3a8c8e0f6d0efba8ea78b10a470a *src/xewma_sf.c 6503b7df8a97761b7480f3bb38c24357 *src/xgrsr_ad.c dbe2b14f60189b36d0e62d3ad5ef2195 *src/xgrsr_arl.c 9b66c453910cb0b82613feefbaca7834 *src/xgrsr_crit.c 1a6b03d4e482ef7fafc01e085afc49f0 *src/xsewma_arl.c 23859f13b9d11b22428adb46dd06fb09 *src/xsewma_crit.c 37996b63005a89201f5562c9061fc442 *src/xsewma_res_arl.c 56cd4e09f23003a9b6b16f0f4b7eb66f *src/xsewma_res_pms.c spc/R/0000755000176000001440000000000012044707400011266 5ustar ripleyusersspc/R/xsewma.arl.R0000644000176000001440000000277411374224766013522 0ustar ripleyusers# 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/xgrsr.crit.R0000644000176000001440000000115711170040372013517 0ustar ripleyusers# 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", 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>g ) 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), ans=double(length=1),PACKAGE="spc")$ans names(g) <- "g" return (g) } spc/R/xsewma.crit.R0000644000176000001440000000315411167344254013671 0ustar ripleyusers# 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=20, 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/xgrsr.ad.R0000644000176000001440000000115311167454516013155 0ustar ripleyusers# Computation of GRSR (Girshick, Rubin, Shiryaev, Roberts) steady-state ARLs (mean monitoring) xgrsr.ad <- function(k, g, mu1, mu0 = 0, zr = 0, sided = "one", 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), ans=double(length=1),PACKAGE="spc")$ans names(ad) <- "ad" return(ad) } spc/R/xs.res.ewma.arl.R0000644000176000001440000000236511532430161014344 0ustar ripleyusers# 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/xDgrsr.arl.R0000644000176000001440000000216411177145337013455 0ustar ripleyusers# 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/sewma.crit.R0000644000176000001440000000345611176246215013504 0ustar ripleyusers# Computation of EWMA critical values for given ARL (variance monitoring) sewma.crit <- function(l, L0, df, sigma0=1, cl=NULL, cu=NULL, hs=1, s2.on=TRUE, sided="upper", mode="fixed", r=40, qm=30) { 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 ( hsh/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=1),PACKAGE="spc")$ans names(arl) <- "arl" return (arl) } spc/R/xcusum.crit.L0L1.R0000644000176000001440000000222211523310765014347 0ustar ripleyusers # 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/xewma.sf.R0000644000176000001440000000262312016370165013147 0ustar ripleyusers# Computation of EWMA survival function (mean monitoring) xewma.sf <- function(l, c, mu, n, zr=0, hs=0, sided="one", 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 ( 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", "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/xewma.crit.R0000644000176000001440000000214311227305767013506 0ustar ripleyusers# 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>1) stop("l has to be between 0 and 1") if (L0<1) stop("L0 is too small") if (r<4) stop("r is too small") if (sided=="one" & hs30 & 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/p.ewma.arl.R0000644000176000001440000000175211641340646013371 0ustar ripleyusers# 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/x.res.ewma.arl.R0000644000176000001440000000137611532414626014172 0ustar ripleyusers# 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/xshewhartrunsrules.crit.R0000644000176000001440000000110611171635330016351 0ustar ripleyusers 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/xewma.ad.R0000644000176000001440000000171611227106471013125 0ustar ripleyusers# Computation of EWMA steady-state ARLs (mean monitoring) xewma.ad <- function(l,c,mu1,mu0=0,zr=0,sided="one",limits="fix",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") ad <- .C("xewma_ad",as.integer(ctyp),as.double(l), as.double(c),as.double(zr),as.double(mu0),as.double(mu1), as.integer(ltyp),as.integer(r), ans=double(length=1),PACKAGE="spc")$ans names(ad) <- "ad" return (ad) } spc/R/xshewhartrunsrules.arl.R0000644000176000001440000000062311171572350016173 0ustar ripleyusers 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/xshewhartrunsrules.matrix.R0000644000176000001440000001206011174121634016715 0ustar ripleyusers 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/xcusum.q.R0000644000176000001440000000136311627162633013210 0ustar ripleyusers# Computation of CUSUM quantiles (mean monitoring) xcusum.q <- function(k, h, mu, p, 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 ( p <= 0 | p >= 1) stop("quantile level p 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(p), as.double(hs), as.double(mu), as.integer(r), ans=double(length=1),PACKAGE="spc")$ans names(quant) <- "q" quant } spc/R/s.res.ewma.arl.R0000644000176000001440000000162511546671665014177 0ustar ripleyusers# 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/xDshewhartrunsrules.arl.R0000644000176000001440000000103411171640520016267 0ustar ripleyusers 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/xcusum.crit.L0h.R0000644000176000001440000000156011523303017014316 0ustar ripleyusers # 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/xDewma.arl.R0000644000176000001440000000246611214125502013416 0ustar ripleyusers# 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/xshewhartrunsrules.ad.R0000644000176000001440000000102111171573520015772 0ustar ripleyusers xshewhartrunsrules.ad <- function(mu1, mu0=0, c=1, type="12") { # Shewhart chart if (type=="1") { p0 <- pnorm( 3*c, mean=mu1 ) - pnorm( -3*c, mean=mu1) ad <- 1/(1-p0) } # ditto with runs rules if (type!="1") { Q1 <- xshewhartrunsrules.matrix(mu1, c=c, type=type) dimQ <- nrow(Q1) one <- rep(1, dimQ) I <- diag(1, dimQ) arls <- solve(I-Q1, one) Q0 <- xshewhartrunsrules.matrix(mu0, c=c, type=type) psi <- Re(eigen(t(Q0))$vectors[,1]) ad <- sum(psi * arls)/sum(psi) } ad }spc/R/xcusum.sf.R0000644000176000001440000000130411721204072013340 0ustar ripleyusers# 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/sewma.arl.R0000644000176000001440000000211111374224746013311 0ustar ripleyusers# Computation of EWMA ARLs (variance monitoring) sewma.arl <- function(l,cl,cu,sigma,df, s2.on=TRUE,hs=1,sided="upper",r=40,qm=30) { 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/phat.ewma.arl.R0000644000176000001440000000200611620757206014060 0ustar ripleyusers# Computation of EWMA phat ARLs phat.ewma.arl <- function(lambda, ucl, mu, n, z0, sigma=1, LSL=-3, USL=3, N=15, qm=15) { if ( lambda <= 0 || lambda > 1 ) stop("lambda has to be between 0 and 1") p.star <- pnorm( LSL ) + pnorm( -USL ) if ( ucl <= p.star ) stop("ucl must be larger than p.star") 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") 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") 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.double(LSL), as.double(USL), as.integer(N), as.integer(qm), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- "arl" arl }spc/R/xewma.arl.R0000644000176000001440000000231611720175343013316 0ustar ripleyusers# 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>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") 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)") 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) <- "arl" return (arl) } spc/R/xDcusum.arl.R0000644000176000001440000000200511177134517013624 0ustar ripleyusers# 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/phat.ewma.lambda.R0000644000176000001440000000203211620752366014523 0ustar ripleyusers# Computation of EWMA phat lambda minimizing certain out-of-control ARL phat.ewma.lambda <- function(L0, mu, n, z0, sigma=1, max_l=1, min_l=.001, LSL=-3, USL=3, qm=15) { p.star <- pnorm( LSL ) + pnorm( -USL ) 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-12 ) stop("sigma much too small") 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.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/xDshewhartrunsrulesFixedm.arl.R0000644000176000001440000000116411171637215017437 0ustar ripleyusers 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/tol.lim.fac.R0000644000176000001440000000113210110211426013502 0ustar ripleyusers# 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/xgrsr.arl.R0000644000176000001440000000142711720216713013341 0ustar ripleyusers# Computation of GRSR (Girshick, Rubin, Shiryaev, Roberts) ARLs (mean monitoring) xgrsr.arl <- function(k, g, mu, zr=0, hs=NULL, sided="one", q=1, r=30) { if (k<0) stop("k has to be non-negative") if (g<0) stop("g has to be positive") if ( !is.null(hs) ) { if ( hs>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), ans=double(length=1),PACKAGE="spc")$ans names(arl) <- "arl" return (arl) }spc/R/xewma.q.R0000644000176000001440000000263611721204077013003 0ustar ripleyusers# Computation of EWMA quantiles (mean monitoring) xewma.q <- function(l, c, mu, p, zr=0, hs=0, sided="one", 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 ( 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", "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(p), 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/xs.res.ewma.pms.R0000644000176000001440000000265011532430327014366 0ustar ripleyusers# 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/phat.ewma.crit.R0000644000176000001440000000170611620752260014244 0ustar ripleyusers# Computation of EWMA phat upper control limits phat.ewma.crit <- function(lambda, L0, mu, n, z0, sigma=1, LSL=-3, USL=3, N=15, qm=15) { if ( lambda <= 0 || lambda > 1 ) stop("lambda has to be between 0 and 1") p.star <- pnorm( LSL ) + pnorm( -USL ) 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-12 ) stop("sigma much too small") 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.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.crit.R0000644000176000001440000000116410061356232013677 0ustar ripleyusers# Computation of CUSUM decision limits for given ARL (mean monitoring) xcusum.crit <- function(k, L0, mu0 = 0, hs = 0, sided = "one", r = 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 (r<4) stop("r is too small") ctyp <- pmatch(sided, c("one", "two", "Crosier")) - 1 if (is.na(ctyp)) stop("invalid cusum type") h <- .C("xcusum_crit",as.integer(ctyp),as.double(k), as.double(L0),as.double(hs),as.double(mu0),as.integer(r), ans=double(length=1),PACKAGE="spc")$ans names(h) <- "h" return (h) } spc/man/0000755000176000001440000000000012044753306011646 5ustar ripleyusersspc/man/xewma.arl.Rd0000644000176000001440000002436612044561761014050 0ustar ripleyusers\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{Returns a single value which resembles the ARL.} \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 ## 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/xcusum.crit.Rd0000644000176000001440000000262512044554644014432 0ustar ripleyusers\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 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).} } \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/sewma.crit.Rd0000644000176000001440000001337112044711424014211 0ustar ripleyusers\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=1,s2.on=TRUE,sided="upper",mode="fixed",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 batch size (for known mean it is equal to the batch size, for unknown mean it is equal to batch 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).} \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).} \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. 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") ## 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 ## 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/xDcusum.arl.Rd0000644000176000001440000001140512044557021014337 0ustar ripleyusers\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}{define whether the first observation used for the ARL calculatio follows already 1*delta or 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 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 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.ad.Rd0000644000176000001440000000542712044563663013702 0ustar ripleyusers\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", 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{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/xDgrsr.arl.Rd0000644000176000001440000000746712044557766014215 0ustar ripleyusers\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}{define whether the first observation used for the ARL calculatio follows already 1*delta or 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{ ## 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.q.Rd0000644000176000001440000000313312044555001013710 0ustar ripleyusers\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, p, 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{p}{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", "p") k <- .5 h <- 3 mu <- 0 # corresponds to Waldmann's -0.5 p.list <- c(.95, .5, .05) rl.quantiles <- ceiling(XCUSUM.Q(k, h, mu, p.list)) cbind(p.list, rl.quantiles) } \keyword{ts} spc/man/xcusum.arl.Rd0000644000176000001440000001223611757162224014245 0ustar ripleyusers\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 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{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/p.ewma.arl.Rd0000644000176000001440000000522112044556211014075 0ustar ripleyusers\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}{batch 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 a 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 (2012), EWMA \code{p} charts under sampling by variables, accepted in \emph{International Journal of Production Research}. } \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 (2012) n <- 5 p0 <- 0.02 z0 <- n*p0 lambda <- 0.3 ucl <- 0.649169922 ## should provide in-control ARL of about 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/xcusum.crit.L0L1.Rd0000644000176000001440000000654012044556441015076 0ustar ripleyusers\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/tol.lim.fact.Rd0000644000176000001440000000476212044423366014440 0ustar ripleyusers\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} spc/man/xshewhartrunsrules.arl.Rd0000644000176000001440000001277412044565571016732 0ustar ripleyusers\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/xewma.q.Rd0000644000176000001440000001035312044562426013520 0ustar ripleyusers\name{xewma.q} \alias{xewma.q} \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, p, 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{p}{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).} } \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.c.of.quantile <- function(l, L0, mu, p, zr=0, hs=0, sided="one", mode="integer", r=40) { c2 <- 0 a2 <- 0 while ( a2 < L0 ) { c2 <- c2 + .5 a2 <- xewma.q(l, c2, mu, p, zr=zr, hs=hs, sided=sided, r=r) if ( mode=="integer" ) a2 <- ceiling(a2) } c1 <- c2 - .5 a1 <- xewma.q(l, c1, mu, p, zr=zr, hs=hs, sided=sided, r=r) a.error <- 1; c.error <- 1 while ( a.error>1e-6 && c.error>1e-12 ) { c3 <- c1 + (L0 - a1)/(a2 - a1)*(c2 - c1) a3 <- xewma.q(l, c3, mu, p, zr=zr, hs=hs, sided=sided, r=r) if ( mode=="integer" ) a3 <- ceiling(a3) c1 <- c2; c2 <- c3 a1 <- a2; a2 <- a3 a.error <- abs(a2 - L0); c.error <- abs(c2 - c1) } c3 } XEWMA.c.of.quantile <- Vectorize("xewma.c.of.quantile", "l") # (ii) re-calculate the thresholds and remove the standardization step L0 <- 500 G.h.new <- XEWMA.c.of.quantile(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/xgrsr.arl.Rd0000644000176000001440000000661612044564102014062 0ustar ripleyusers\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, 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{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 single value which resembles the 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 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) ## Table 4 from Moustakides et al. (2009) ## original values are # gamma A ARL/E_infty(L) SADD/E_1(L) # 50 28.02 50.79 5.46 # 100 56.04 100.79 6.71 # 500 280.19 500.8 9.78 # 1000 560.37 1000.79 11.14 # 5000 2801.75 5001.75 14.34 # 10000 5603.7 10000.78 15.73 Gxgrsr.arl <- Vectorize("xgrsr.arl", "g") As <- c(28.02, 56.04, 280.19, 560.37, 2801.75, 5603.7) gs <- log(As) theta <- 1 zr <- -6 arls0 <- round(Gxgrsr.arl(theta/2, gs, 0, zr=zr, r=100), digits=2) arls1 <- round(Gxgrsr.arl(theta/2, gs, theta, zr=zr, r=100), digits=2) data.frame(As, arls0, arls1) } \keyword{ts} spc/man/xcusum.ad.Rd0000644000176000001440000000535512044544206014051 0ustar ripleyusers\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/xsewma.arl.Rd0000644000176000001440000000744612044564771014237 0ustar ripleyusers\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 batch size (for known mean it is equal to the batch size, for unknown mean it is equal to batch 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 # batch 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/phat.ewma.arl.Rd0000644000176000001440000000763412044556232014607 0ustar ripleyusers\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, LSL=-3, USL=3, N=15, qm=15) phat.ewma.crit(lambda, L0, mu, n, z0, sigma=1, LSL=-3, USL=3, N=15, qm=15) phat.ewma.lambda(L0, mu, n, z0, sigma=1, max_l=1, min_l=.001, LSL=-3, USL=3, qm=15) } \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}{batch size.} \item{z0}{so-called headstart (give fast initial response).} \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.} } \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 (2012), EWMA \code{p} charts under sampling by variables, accepted in \emph{International Journal of Production Research}. } \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 (2012), # 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 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/xcusum.sf.Rd0000644000176000001440000000331512044563377014101 0ustar ripleyusers\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/xcusum.crit.L0h.Rd0000644000176000001440000000343012044546200015034 0ustar ripleyusers\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/sewma.arl.Rd0000644000176000001440000000652312044564606014037 0ustar ripleyusers\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=1,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 batch size (for known mean it is equal to the batch size, for unknown mean it is equal to batch 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).} \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 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 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/xewma.ad.Rd0000644000176000001440000000522112044561403013634 0ustar ripleyusers\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,sided="one",limits="fix",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{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).} } \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{ 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/xsewma.crit.Rd0000644000176000001440000000725012044565067014412 0ustar ripleyusers\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=20, 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 batch size (for known mean it is equal to the batch size, for unknown mean it is equal to batch 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 # batch 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/xDewma.arl.Rd0000644000176000001440000002251012044557756014152 0ustar ripleyusers\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}{define whether the first observation used for the ARL calculatio follows already 1*delta or 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{ 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), 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/xsresewma.arl.Rd0000644000176000001440000001620012044704034014721 0ustar ripleyusers\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{ ## 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/xewma.crit.Rd0000644000176000001440000000366112044562253014223 0ustar ripleyusers\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/xgrsr.crit.Rd0000644000176000001440000000362612044564315014251 0ustar ripleyusers\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", 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{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/xewma.sf.Rd0000644000176000001440000000610112044566121013660 0ustar ripleyusers\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/xDshewhartrunsrules.arl.Rd0000644000176000001440000000647711177144632017036 0ustar ripleyusers\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/src/0000755000176000001440000000000012044753306011662 5ustar ripleyusersspc/src/xDgrsr_arl.c0000644000176000001440000000163212044757605014145 0ustar ripleyusers#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/xgrsr_crit.c0000644000176000001440000000054112044757605014222 0ustar ripleyusers#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); void xgrsr_crit(double *k, double *L0, double *zr, double *hs, double *mu0, int *r, double *h) { *h = xsr1_crit(*k, *L0, *zr, *hs, *mu0, *r); } spc/src/xcusum_crit.c0000644000176000001440000000047012044757605014402 0ustar ripleyusers#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/xsewma_crit.c0000644000176000001440000000315212044757605014362 0ustar ripleyusers#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; 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); } c_values[0] = cx; c_values[1] = cl; c_values[2] = cu; } spc/src/xgrsr_ad.c0000644000176000001440000000060312044757605013644 0ustar ripleyusers#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); void xgrsr_ad(int *ctyp, double *k, double *h, double *mu0, double *mu1, double *zr, int *r, double *ad) { if (*ctyp==grsr1) *ad = xsr1_iglad(*k, *h, *zr, *mu0, *mu1, *r); } spc/src/sewma_crit.c0000644000176000001440000000260212044757605014171 0ustar ripleyusers#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(double l, double L0, double hs, double sigma, int df, int N, int qm, int s_squared); double seUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm, int s_squared); double seLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm, int s_squared); double se2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); int se2_crit(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm); 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, int *s_squared, double *c_values) { int result; double cl=0., cu=1.; if (*ctyp==ewmaU) cu = seU_crit(*l,*L0,*hs,*sigma,*df,*r,*qm,*s_squared); if (*ctyp==ewmaUR) cu = seUR_crit(*l,*L0,*cl0,*hs,*sigma,*df,*r,*qm,*s_squared); if (*ctyp==ewmaLR) cl = seLR_crit(*l,*L0,*cu0,*hs,*sigma,*df,*r,*qm,*s_squared); 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(*l,*L0,&cl,&cu,*hs,*sigma,*df,*r,*qm); } c_values[0] = cl; c_values[1] = cu; } spc/src/xewma_q.c0000644000176000001440000000177712044757605013511 0ustar ripleyusers#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 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) { if ( *ctyp==ewma1 ) *tq = xe1_Wq(*l, *c, *p, *zr, *hs, *mu, *r, 100); if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xe2_Wq(*l, *c, *p, *hs, *mu, *r, 10000); if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xe2_Wqm(*l, *c, *p, *hs, *q, 0., *mu, *ltyp, *r, 10000); if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xe2_Wqm(*l, *c, *p, *hs, *q, 0., *mu, *ltyp, *r, 10000); } spc/src/ewma_phat_crit_coll.c0000644000176000001440000000071512044757605016036 0ustar ripleyusers#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); void ewma_phat_crit_coll (double *lambda, double *L0, double *mu, double *sigma, int *n, double *z0, double *LSL, double *USL, int *N, int *qm, double *ucl) { *ucl = -1.; *ucl = ewma_phat_crit(*lambda, *L0, *mu, *sigma, *n, *z0, *LSL, *USL, *N, *qm); } spc/src/xewma_arl.c0000644000176000001440000000425612044757605014022 0ustar ripleyusers#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 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 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); 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; if (*ctyp==ewma1 && *ltyp==fix && *q==1) *arl = xe1_iglarl(*l,*c,*zr,*hs,*mu,*r); if (*ctyp==ewma1 && *ltyp==fix && *q>1) *arl = xe1_arlm(*l,*c,*zr,*hs,*q,0.,*mu,*ltyp,*r,nmax); if (*ctyp==ewma1 && *ltyp>fix && *ltyp1) *arl = xe2_arlm(*l,*c,*hs,*q,0.,*mu,*ltyp,*r,nmax); if (*ctyp==ewma2 && *ltyp>fix && *ltyp #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/tol_lim_fac.c0000644000176000001440000000055612044757605014312 0ustar ripleyusers#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/allspc.c0000644000176000001440000045431512044757605013326 0ustar ripleyusers#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 /*** 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 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); /* 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 */ /* 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); /* Shiryaev-Roberts (only the one-sided version is implemented) */ double xsr1_crit(double k, double L0, double zr, double hs, double m0, int N); double xsr1_iglarl(double k, double h, double zr, double hs, double mu, int N); double xsr1_iglad(double k, double h, double zr, double mu0, double mu1, int N); double xsr1_arlm(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int nmax); 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); /* 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_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_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_arlm(double l, double c, 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); 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_Carl(double l, double c, double hs, double mu, int N, int qm); 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); /* 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); /* variance charts */ double seU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm, int s_squared); 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 seU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm, int s_squared); 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(double l, double L0, double *cl, double *cu, 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, int s_squared); double seLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm, int s_squared); /* 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); /* 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 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 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_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); /* 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); static void gausslegendre(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 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 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 noncentral 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 noncentral 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 noncentral chisquare rv */ double nqCHI(double p, int df, double ncp) { return qnchisq(p,(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); } /* roots and abscissae 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 += .5; L2 = BM_xc_arl(k, c2, m0); } while (L21e-6) && (fabs(dc)>1e-8) ); 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-5) && (fabs(dc)>1e-6) ); return c3; } double xsr1_crit(double k, double L0, double zr, double hs, double m0, int N) { double c1, c2, c3, L1, L2, L3, dc; c2 = 0.; do { c2 += .5; L2 = xsr1_iglarl(k, c2, zr, hs, m0, N); } while ( L21e-5) && (fabs(dc)>1e-6) ); 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.; int nmax=100000; if ( (ctyp==ewma1 && c0 < zr) || (ctyp==ewma2 && c0 < 0.) ) c2 = 1.; else c2 = c0; if (ctyp==ewma1 && ltyp==fix && hs>=0.) L2 = xe1_iglarl ( l,c2,zr,hs,m0,N ); if (ctyp==ewma1 && ltyp==fix && hs<0.) L2 = xe1_iglarl ( l,c2,zr,c2/2,m0,N ); if (ctyp==ewma1 && ltyp>fix && hs>=0.) L2 = xe1_arlm ( l,c2,zr,hs,1,m0,m0,ltyp,N,nmax ); if (ctyp==ewma1 && ltyp>fix && hs<0.) L2 = xe1_arlm ( l,c2,zr,c2/2,1,m0,m0,ltyp,N,nmax ); if (ctyp==ewma2 && ltyp==fix) L2 = xe2_iglarl ( l,c2,hs,m0,N ); if (ctyp==ewma2 && 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. ) 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; c2 += norm; if (ctyp==ewma1 && ltyp==fix && hs>=0.) L2 = xe1_iglarl ( l,c2,zr,hs,m0,N ); if (ctyp==ewma1 && ltyp==fix && hs<0.) L2 = xe1_iglarl ( l,c2,zr,c2/2,m0,N ); if (ctyp==ewma1 && ltyp>fix && hs>=0.) L2 = xe1_arlm ( l,c2,zr,hs,1,m0,m0,ltyp,N,nmax ); if (ctyp==ewma1 && ltyp>fix && hs<0.) L2 = xe1_arlm ( l,c2,zr,c2/2,1,m0,m0,ltyp,N,nmax ); if (ctyp==ewma2 && ltyp==fix) L2 = xe2_iglarl ( l,c2,hs,m0,N ); if (ctyp==ewma2 && 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. ) error("invalid ARL value"); if ( c2 <= 1e-9 && fabs(L2-L2old)>100. ) norm = -.001; } while ( (L2 < L0 && norm>0.) || (L2 > L0 && norm<0.) ); c1 = c2 - norm; if (ctyp==ewma1 && ltyp==fix && hs>=0.) L1 = xe1_iglarl ( l,c1,zr,hs,m0,N ); if (ctyp==ewma1 && ltyp==fix && hs<0.) L1 = xe1_iglarl ( l,c1,zr,c1/2,m0,N ); if (ctyp==ewma1 && ltyp>fix && hs>=0.) L1 = xe1_arlm ( l,c1,zr,hs,1,m0,m0,ltyp,N,nmax ); if (ctyp==ewma1 && ltyp>fix && hs<0.) L1 = xe1_arlm ( l,c1,zr,c1/2,1,m0,m0,ltyp,N,nmax ); if (ctyp==ewma2 && ltyp==fix) L1 = xe2_iglarl ( l,c1,hs,m0,N ); if (ctyp==ewma2 && ltyp>fix) { if (hs<0. && ltyp==fir) L1 = xe2_arlm ( l,c1,c1/2.,1,m0,m0,ltyp,N,nmax ); if (hs<0. && ltyp==both) L1 = xe2_arlm ( l,c1,c1/2.*sqrt(l*(2.-l)),1,m0,m0,ltyp,N,nmax ); if (hs>=0.) L1 = xe2_arlm ( l,c1,hs,1,m0,m0,ltyp,N,nmax ); if ( L1 < 1. ) error("invalid ARL value"); } do { c3 = c1 + (L0-L1)/(L2-L1) * (c2-c1); if (ctyp==ewma1 && ltyp==fix && hs>=0.) L3 = xe1_iglarl ( l,c3,zr,hs,m0,N ); if (ctyp==ewma1 && ltyp==fix && hs<0.) L3 = xe1_iglarl ( l,c3,zr,c3/2,m0,N ); if (ctyp==ewma1 && ltyp>fix && hs>=0.) L3 = xe1_arlm ( l,c3,zr,hs,1,m0,m0,ltyp,N,nmax ); if (ctyp==ewma1 && ltyp>fix && hs<0.) L3 = xe1_arlm ( l,c3,zr,c3/2,1,m0,m0,ltyp,N,nmax ); if (ctyp==ewma2 && ltyp==fix) L3 = xe2_iglarl ( l,c3,hs,m0,N ); if (ctyp==ewma2 && 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 ); } 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-8) ); 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( (q_plus-q_minus)/q_minus )n), 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_iglarl_drift(double k, double h, double hs, double delta, int m, int N, int with0) { double *a, *g, *w, *z, arl, *MUs, *ARLs; int i, j, NN, m_; NN = N + 1; a = matrix(NN, NN); g = vector(NN); w = vector(NN); z = vector(NN); ARLs = vector(NN); MUs = vector(m+1); gausslegendre(N, 0., h, 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 = 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 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;i h) { arl = 1. + PHI( zr+k, mu) * g[N]; for (j=0;jn), 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) { 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, 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 xsr1_iglarl_drift(double k, double h, double zr, double hs, double delta, int m, int N, int with0) { double *a, *g, *w, *z, arl, *MUs, *ARLs; int i, j, NN, m_; NN = N + 1; a = matrix(NN, NN); g = vector(NN); w = vector(NN); z = vector(NN); ARLs = vector(NN); MUs = vector(m+1); gausslegendre(N, zr, h, 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;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) { double *a, *w, *z, *arl, *psi, rho, ad, norm; int i, j, status, noofit, NN; 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( (q_plus-q_minus)/q_minus )n), 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; iq ) { 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( (q_plus-q_minus)/q_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; } 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] ); if ( enumerator < 0. ) { q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); } else { q_minus = (double)n + enumerator/log(mn_plus); q_plus = (double)n + enumerator/log(mn_minus); } } if ( fabs( (q_plus-q_minus)/q_minus )1)(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] = 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] = 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 xlimit1_arlm(double c, double zr, int q, double mu0, double mu1, int N, int nmax) { double *Smatrix, *p0, *fn, *w, *z, l1, l2, arl0, rho, arl_minus=0, arl, arl_plus=0, mn_minus, mn_plus, nn, ratio; int i=0, j=0, n, NN; 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); /* in-control, i. e. n<=q-1 */ 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 (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 qm_for_l_and_c(double l, double c) { int qm=20; qm = (int)ceil( 3.141 * c / sqrt(l) ); /*printf("l = %.2f,\tc = %.6f,\tqm = %d\n", l, c, qm);*/ if ( qm < 20 ) qm = 20; if ( qm > 1000 ) qm = 1000; return qm; } double xc2_iglad (double k, double h, double mu0, double mu1, int N) { double *a, *arl, *psi, rho, ad, norm, z1, z2, z11, z12, z21, z22, w; int i1, i2, j1, j2, status, noofit, NN, N3; NN = N*N; N3 = NN*N; a = matrix(NN,NN); arl = vector(NN); psi = vector(NN); w = 2.*h/(2.*N - 1.); for (i1=0;i1z2) 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;i15) result = cos( (double)(n)*acos(z) ); } else { if (z<0. && (n % 2 == 1)) result = -1.; else result = 1.; } return result; } double seU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm, int s_squared) { 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;i1e-6 && fabs(ds)>1e-7 ); return s3; } double seUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm, int s_squared) { 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 seLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm, int s_squared) { double s1, s2, s3, ds, L1, L2, L3; s2 = hs; do { s2 -= .1; L2 = seLR_iglarl(l, s2, cu, hs, sigma, df, N, qm); } while (L20.); s1 = s2 + .1; L1 = seLR_iglarl(l, s1, cu, hs, sigma, df, N, qm); 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 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 = 0.; 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-7 ); 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; s2 = cu/2.; L2 = se2_iglarl(l,s2,cu,hs,sigma,df,N,qm); if ( L2L0); s1 = s2 - .1; } 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-6 && fabs(ds)>1e-7 ); return s3; } int se2_crit (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; int s_squared=1; s1 = seU_crit(l,L0,hs,sigma,df,N,qm,s_squared); csl = 0.; Lm = seU_iglarl(l,s1,hs,sigma-lmEPS,df,N,qm,s_squared); Lp = seU_iglarl(l,s1,hs,sigma+lmEPS,df,N,qm,s_squared); sl1 = (Lp-Lm)/(2.*lmEPS); s2 = s1 + .05; 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); 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-6 && fabs(ds)>1e-7 ); *cl = csl; *cu = s3; return 0; } 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-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-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 (t01)(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 )1e-6 || fabs(xARL2-sARL2)>1e-6) && (fabs(x2-x1)>1e-8 || fabs(s2-s1)>1e-8) ); *cx = x2; *cs = s2; 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 )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); 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); } 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); 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); 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); 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; } /* 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; dn = (double)n; result = 0.; if ( p >= 1. ) result = 1.; pstar = WK_h(0., 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; dn = (double)n; result = 0.; pstar = WK_h(0., 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; } 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; int i, j, k; dN = (double)N; a = matrix(N,N); g = vector(N); w = vector(qm); z = vector(qm); pstar = WK_h(0., 1., LSL, USL); for (i=0; i1e-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; } /* 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 #define cusumC 2 #define igl 0 #define mc 1 extern double rho0; 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 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 nmax=100000; double lhs; if ( *ctyp == cusum1 && *q==1 ) *arl = xc1_iglarl(*k,*h,*hs,*mu,*r); if ( *ctyp == cusum1 && *q>1 ) *arl = xc1_arlm(*k, *h, *hs, *q, 0., *mu, *r, nmax); if ( *ctyp == cusum2 ) { if ( *method == igl ) *arl = xc2_iglarl(*k,*h,*hs,*mu,*r); lhs = - *hs; if ( *method == mc ) *arl = xc2_be_arl(*k,*h,*hs,lhs,*mu,*r); } if ( *ctyp == cusumC ) *arl = xcC_iglarl(*k,*h,*hs,*mu,*r); } spc/src/xcusum_ad.c0000644000176000001440000000141012044757605014020 0ustar ripleyusers#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/xgrsr_arl.c0000644000176000001440000000114512044757605014040 0ustar ripleyusers#include #include #include #include #define grsr1 0 #define grsr2 1 extern double rho0; double xsr1_iglarl(double k, double h, double zr, double hs, double mu, int N); double xsr1_arlm(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int nmax); void xgrsr_arl(int *ctyp, double *k, double *h, double *zr, double *hs, double *mu, int *q, int *r, double *arl) { int nmax=100000; if (*ctyp==grsr1 && *q==1) *arl = xsr1_iglarl(*k, *h, *zr, *hs, *mu, *r); if (*ctyp==grsr1 && *q>1) *arl = xsr1_arlm(*k, *h, *zr, *hs, *q, 0., *mu, *r, nmax); } spc/src/sewma_res_arl.c0000644000176000001440000000064512044757605014664 0ustar ripleyusers#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/xcusum_q.c0000644000176000001440000000055412044757605013704 0ustar ripleyusers#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/xDcusum_arl.c0000644000176000001440000000165412044757605014330 0ustar ripleyusers#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/xsewma_res_arl.c0000644000176000001440000000107512044757605015052 0ustar ripleyusers#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/xsewma_arl.c0000644000176000001440000000162312044757605014200 0ustar ripleyusers#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_arl.c0000644000176000001440000000175612044757605014017 0ustar ripleyusers#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, int s_squared); 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); 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 (*ctyp==ewmaU) *arl = seU_iglarl(*l,*cu,*hs,*sigma,*df,*r,*qm,*s_squared); 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); } spc/src/ewma_phat_arl_coll.c0000644000176000001440000000071512044757605015653 0ustar ripleyusers#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); void ewma_phat_arl_coll (double *lambda, double *ucl, double *mu, double *sigma, int *n, double *z0, double *LSL, double *USL, int *N, int *qm, double *arl) { *arl = -1.; *arl = ewma_phat_arl(*lambda, *ucl, *mu, *sigma, *n, *z0, *LSL, *USL, *N, *qm); } spc/src/xewma_ad.c0000644000176000001440000000203212044757605013616 0ustar ripleyusers#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 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_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, int *ltyp, int *r, double *ad) { 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,10000); 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,10000); } spc/src/xewma_sf.c0000644000176000001440000000222012044757605013641 0ustar ripleyusers#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 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, i; double *p0; p0 = vector(*n); if ( *ctyp==ewma1 ) result = xe1_sf(*l, *c, *zr, *hs, *mu, *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); for (i=0; i<*n; i++) sf[i] = p0[i]; } spc/src/ewma_phat_lambda_coll.c0000644000176000001440000000075312044757605016317 0ustar ripleyusers#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); void ewma_phat_lambda_coll (double *L0, double *mu, double *sigma, double *max_l, double *min_l, int *n, double *z0, double *LSL, double *USL, int *qm, double *lambda) { *lambda = -1.; *lambda = ewma_phat_lambda(*L0, *mu, *sigma, *max_l, *min_l, *n, *z0, *LSL, *USL, *qm); } spc/src/xewma_res_arl.c0000644000176000001440000000054712044757605014672 0ustar ripleyusers#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/xcusum_sf.c0000644000176000001440000000073412044757605014054 0ustar ripleyusers#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, i; double *p0; p0 = vector(*n); if (*ctyp==cusum1) result = xc1_sf(*k, *h, *hs, *mu, *r, *n, p0); for (i=0; i<*n; i++) sf[i] = p0[i]; } spc/src/xewma_crit.c0000644000176000001440000000061012044757605014173 0ustar ripleyusers#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/ewma_p_arl_be.c0000644000176000001440000000065012044757605014611 0ustar ripleyusers#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/xDewma_arl.c0000644000176000001440000000362312044757605014123 0ustar ripleyusers#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/NAMESPACE0000644000176000001440000000132612044707357012321 0ustar ripleyusersuseDynLib(spc) export("xshewhartrunsrules.ad", "xshewhartrunsrules.arl", "xshewhartrunsrules.crit", "xshewhartrunsrules.matrix", "xewma.ad", "xewma.arl", "xewma.crit", "xewma.q", "xewma.sf", "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", "xsewma.arl", "xsewma.crit", "xDcusum.arl", "xDewma.arl", "xDgrsr.arl", "xDshewhartrunsrules.arl", "xDshewhartrunsrulesFixedm.arl", "p.ewma.arl", "phat.ewma.arl", "phat.ewma.crit", "phat.ewma.lambda", "s.res.ewma.arl", "x.res.ewma.arl", "xs.res.ewma.arl", "xs.res.ewma.pms", "tol.lim.fac")spc/DESCRIPTION0000644000176000001440000000171212044761316012602 0ustar ripleyusersPackage: spc Version: 0.4.2 Date: 2012-10-31 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 Packaged: 2012-11-02 14:58:13 UTC; ripley Repository: CRAN Date/Publication: 2012-11-02 15:12:14