spc/0000755000176200001440000000000014325502512011036 5ustar liggesusersspc/NAMESPACE0000644000176200001440000000345614017160703012265 0ustar liggesusersuseDynLib(spc, .registration=TRUE) ## imports import("stats") ## exports export("xshewhartrunsrules.ad", "xshewhartrunsrules.arl", "xshewhartrunsrules.crit", "xshewhartrunsrules.matrix", "xshewhart.ar1.arl", "xtshewhart.ar1.arl", "xewma.ad", "xewma.arl", "xewma.arl.f", "xewma.crit", "xewma.q", "xewma.sf", "xewma.q.crit", "xcusum.ad", "xcusum.arl", "xcusum.crit.L0h", "xcusum.crit.L0L1", "xcusum.crit", "xcusum.q", "xcusum.sf", "xgrsr.ad", "xgrsr.arl", "xgrsr.crit", "sewma.arl", "sewma.crit", "sewma.sf", "sewma.q.crit", "sewma.q", "sewma.sf.prerun", "sewma.arl.prerun", "sewma.q.crit.prerun", "sewma.q.prerun", "sewma.crit.prerun", "lns2ewma.arl", "lns2ewma.crit", "scusum.arl", "scusum.crit", "scusums.arl", "mewma.arl", "mewma.crit", "mewma.psi", "mewma.arl.f", "mewma.ad", "xsewma.arl", "xsewma.crit", "xsewma.sf", "xsewma.q.crit", "xsewma.q", "xewma.arl.prerun", "xewma.q.prerun", "xewma.sf.prerun", "xewma.crit.prerun", "xewma.q.crit.prerun", "xtewma.arl", "xtewma.ad", "xtewma.sf", "xtewma.q", "xtewma.q.crit", "xtcusum.arl", "xDcusum.arl", "xDewma.arl", "xDgrsr.arl", "xDshewhartrunsrules.arl", "xDshewhartrunsrulesFixedm.arl", "p.ewma.arl", "tewma.arl", "euklid.ewma.arl", "pois.ewma.arl", "pois.ewma.crit", "pois.ewma.ad", "pois.cusum.arl", "pois.cusum.crit", "pois.cusum.crit.L0L1", "imr.arl", "imr.Ru_Mgiven", "imr.Ru_Mgiven", "imr.Rl_Mgiven", "imr.MandRu", "imr.MandRuRl", "imr.RuRl_alone_tail", "imr.RuRl_alone_s3", "imr.RuRl_alone", "imr.Ru_Rlgiven", "phat.ewma.arl", "phat.ewma.crit", "phat.ewma.lambda", "dphat", "pphat", "qphat", "s.res.ewma.arl", "x.res.ewma.arl", "xs.res.ewma.arl", "xs.res.ewma.pms", "quadrature.nodes.weights", "tol.lim.fac") spc/man/0000755000176200001440000000000014325474752011627 5ustar liggesusersspc/man/xtewma.q.Rd0000644000176200001440000000605013553640534013656 0ustar liggesusers\name{xtewma.q} \alias{xtewma.q} \alias{xtewma.q.crit} \title{Compute RL quantiles of EWMA control charts} \description{Computation of quantiles of the Run Length (RL) for EWMA control charts monitoring normal mean.} \usage{xtewma.q(l, c, df, mu, alpha, zr=0, hs=0, sided="two", limits="fix", mode="tan", q=1, r=40) xtewma.q.crit(l, L0, df, mu, alpha, zr=0, hs=0, sided="two", limits="fix", mode="tan", r=40, c.error=1e-12, a.error=1e-9, OUTPUT=FALSE)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{df}{degrees of freedom -- parameter of the t distribution.} \item{mu}{true mean.} \item{alpha}{quantile level.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different control limits behavior.} \item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently, \code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\geq)}, will be determined. Note that mu0=0 is implicitely fixed.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} \item{L0}{in-control quantile value.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{a.error}{error bound for the quantile level \code{alpha} during applying the secant rule.} \item{OUTPUT}{activate or deactivate additional output.} } \details{ Instead of the popular ARL (Average Run Length) quantiles of the EWMA stopping time (Run Length) are determined. The algorithm is based on Waldmann's survival function iteration procedure. If \code{limits} is \code{"vacl"}, then the method presented in Knoth (2003) is utilized. For details see Knoth (2004). } \value{Returns a single value which resembles the RL quantile of order \code{q}.} \references{ F. F. Gan (1993), An optimal design of EWMA control charts based on the median run length, \emph{J. Stat. Comput. Simulation 45}, 169-184. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{xewma.q} for RL quantile computation of EWMA control charts in the normal case. } \examples{ ## will follow } \keyword{ts} spc/man/xcusum.arl.Rd0000644000176200001440000001240413553640534014213 0ustar liggesusers\name{xcusum.arl} \alias{xcusum.arl} \title{Compute ARLs of CUSUM control charts} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of CUSUM control charts monitoring normal mean.} \usage{xcusum.arl(k, h, mu, hs = 0, sided = "one", method = "igl", q = 1, r = 30)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.} \item{mu}{true mean.} \item{hs}{so-called headstart (give fast initial response).} \item{sided}{distinguish between one-, two-sided and Crosier's modified two-sided CUSUM scheme by choosing \code{"one"}, \code{"two"}, and \code{"Crosier"}, respectively.} \item{method}{deploy the integral equation (\code{"igl"}) or Markov chain approximation (\code{"mc"}) method to calculate the ARL (currently only for two-sided CUSUM implemented).} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\ge q)}, will be determined. Note that mu0=0 is implicitely fixed.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-, two-sided) or \code{2r+1} (Crosier).} } \details{ \code{xcusum.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature. } \value{Returns a vector of length \code{q} which resembles the ARL and the sequence of conditional expected delays for \code{q}=1 and \code{q}>1, respectively.} \references{ A. L. Goel, S. M. Wu (1971), Determination of A.R.L. and a contour nomogram for CUSUM charts to control normal mean, \emph{Technometrics 13}, 221-230. D. Brook, D. A. Evans (1972), An approach to the probability distribution of cusum run length, \emph{Biometrika 59}, 539-548. J. M. Lucas, R. B. Crosier (1982), Fast initial response for cusum quality-control schemes: Give your cusum a headstart, \emph{Technometrics 24}, 199-205. L. C. Vance (1986), Average run lengths of cumulative sum control charts for controlling normal means, \emph{Journal of Quality Technology 18}, 189-193. K.-H. Waldmann (1986), Bounds for the distribution of the run length of one-sided and two-sided CUSUM quality control schemes, \emph{Technometrics 28}, 61-67. R. B. Crosier (1986), A new two-sided cumulative quality control scheme, \emph{Technometrics 28}, 187-194. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL computation of EWMA control charts and \code{xcusum.ad} for the steady-state ARL. } \examples{ ## Brook/Evans (1972), one-sided CUSUM ## Their results are based on the less accurate Markov chain approach. k <- .5 h <- 3 round(c( xcusum.arl(k,h,0), xcusum.arl(k,h,1.5) ),digits=2) ## results in the original paper are L0 = 117.59, L1 = 3.75 (in Subsection 4.3). ## Lucas, Crosier (1982) ## (one- and) two-sided CUSUM with possible headstarts k <- .5 h <- 4 mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,4,5) arl1 <- sapply(mu,k=k,h=h,sided="two",xcusum.arl) arl2 <- sapply(mu,k=k,h=h,hs=h/2,sided="two",xcusum.arl) round(cbind(mu,arl1,arl2),digits=2) ## results in the original paper are (in Table 1) ## 0.00 168. 149. ## 0.25 74.2 62.7 ## 0.50 26.6 20.1 ## 0.75 13.3 8.97 ## 1.00 8.38 5.29 ## 1.50 4.75 2.86 ## 2.00 3.34 2.01 ## 2.50 2.62 1.59 ## 3.00 2.19 1.32 ## 4.00 1.71 1.07 ## 5.00 1.31 1.01 ## Vance (1986), one-sided CUSUM ## The first paper on using Nystroem method and Gauss-Legendre quadrature ## for solving the ARL integral equation (see as well Goel/Wu, 1971) k <- 0 h <- 10 mu <- c(-.25,-.125,0,.125,.25,.5,.75,1) round(cbind(mu,sapply(mu,k=k,h=h,xcusum.arl)),digits=2) ## results in the original paper are (in Table 1 incl. Goel/Wu (1971) results) ## -0.25 2071.51 ## -0.125 400.28 ## 0.0 124.66 ## 0.125 59.30 ## 0.25 36.71 ## 0.50 20.37 ## 0.75 14.06 ## 1.00 10.75 ## Waldmann (1986), ## one- and two-sided CUSUM ## one-sided case k <- .5 h <- 3 mu <- c(-.5,0,.5) round(sapply(mu,k=k,h=h,xcusum.arl),digits=2) ## results in the original paper are 1963, 117.4, and 17.35, resp. ## (in Tables 3, 1, and 5, resp.). ## two-sided case k <- .6 h <- 3 round(xcusum.arl(k,h,-.2,sided="two"),digits=1) # fits to Waldmann's setup ## result in the original paper is 65.4 (in Table 6). ## Crosier (1986), Crosier's modified two-sided CUSUM ## He introduced the modification and evaluated it by means of ## Markov chain approximation k <- .5 h <- 3.73 mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,4,5) round(cbind(mu,sapply(mu,k=k,h=h,sided="Crosier",xcusum.arl)),digits=2) ## results in the original paper are (in Table 3) ## 0.00 168. ## 0.25 70.7 ## 0.50 25.1 ## 0.75 12.5 ## 1.00 7.92 ## 1.50 4.49 ## 2.00 3.17 ## 2.50 2.49 ## 3.00 2.09 ## 4.00 1.60 ## 5.00 1.22 ## SAS/QC manual 1999 ## one- and two-sided CUSUM schemes ## one-sided k <- .25 h <- 8 mu <- 2.5 print(xcusum.arl(k,h,mu),digits=12) print(xcusum.arl(k,h,mu,hs=.1),digits=12) ## original results are 4.1500836225 and 4.1061588131. ## two-sided print(xcusum.arl(k,h,mu,sided="two"),digits=12) ## original result is 4.1500826715. } \keyword{ts} spc/man/xewma.arl.f.Rd0000644000176200001440000000266413553640534014243 0ustar liggesusers\name{xewma.arl.f} \alias{xewma.arl.f} \title{Compute ARL function of EWMA control charts} \description{Computation of the (zero-state) Average Run Length (ARL) function for different types of EWMA control charts monitoring normal mean.} \usage{xewma.arl.f(l,c,mu,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{mu}{true mean.} \item{zr}{reflection border for the one-sided chart.} \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{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{ It is a convenience function to yield the ARL as function of the head start \code{hs}. For more details see \code{xewma.arl}. } \value{It returns a function of a single argument, \code{hs=x} which maps the head-start value \code{hs} to the 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. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL for one specific head-start \code{hs}. } \examples{ # will follow } \keyword{ts} spc/man/xDgrsr.arl.Rd0000644000176200001440000000751213553640534014144 0ustar liggesusers\name{xDgrsr.arl} \alias{xDgrsr.arl} \title{Compute ARLs of Shiryaev-Roberts schemes under drift} \description{Computation of the (zero-state and other) Average Run Length (ARL) under drift for Shiryaev-Roberts schemes monitoring normal mean.} \usage{xDgrsr.arl(k, g, delta, zr = 0, hs = NULL, sided = "one", m = NULL, mode = "Gan", q = 1, r = 30, with0 = FALSE)} \arguments{ \item{k}{reference value of the Shiryaev-Roberts scheme.} \item{g}{control limit (alarm threshold) of Shiryaev-Roberts scheme.} \item{delta}{true drift parameter.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided Shiryaev-Roberts schemes by choosing \code{"one"} and \code{"two"}, respectively. Currentlly, the two-sided scheme is not implemented.} \item{m}{parameter used if \code{mode="Gan"}. \code{m} is design parameter of Gan's approach. If \code{m=NULL}, then \code{m} will increased until the resulting ARL does not change anymore.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\geq)}, will be determined. Note that mu0=0 is implicitely fixed. Deploy large \code{q} to mimic steady-state. It works only for \code{mode="Knoth"}.} \item{mode}{decide whether Gan's or Knoth's approach is used. Use \code{"Gan"} and \code{"Knoth"}, respectively. \code{"Knoth"} is not implemented yet.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} \item{with0}{defines whether the first observation used for the RL calculation follows already 1*delta or still 0*delta. With \code{q} additional flexibility is given.} } \details{ Based on Gan (1991) or Knoth (2003), the ARL is calculated for Shiryaev-Roberts schemes under drift. In case of Gan's framework, the usual ARL function with mu=m*delta is determined and recursively via m-1, m-2, ... 1 (or 0) the drift ARL determined. The framework of Knoth allows to calculate ARLs for varying parameters, such as control limits and distributional parameters. For details see the cited papers. } \value{Returns a single value which resembles the ARL.} \references{ F. F. Gan (1991), EWMA control chart under linear drift, \emph{J. Stat. Comput. Simulation 38}, 181-200. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2012), More on Control Charting under Drift, in: \emph{Frontiers in Statistical Quality Control 10}, H.-J. Lenz, W. Schmid and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 53-68. C. Zou, Y. Liu and Z. Wang (2009), Comparisons of control schemes for monitoring the means of processes subject to drifts, \emph{Metrika 70}, 141-163. } \author{Sven Knoth} \seealso{ \code{xewma.arl} and \code{xewma.ad} for zero-state and steady-state ARL computation of EWMA control charts for the classical step change model. } \examples{ \dontrun{ ## Monte Carlo example with 10^8 replicates # delta arl s.e. # 0.0001 381.8240 0.0304 # 0.0005 238.4630 0.0148 # 0.001 177.4061 0.0097 # 0.002 125.9055 0.0061 # 0.005 75.7574 0.0031 # 0.01 50.2203 0.0018 # 0.02 32.9458 0.0011 # 0.05 18.9213 0.0005 # 0.1 12.6054 0.0003 # 0.5 5.2157 0.0001 # 1 3.6537 0.0001 # 3 2.0289 0.0000 k <- .5 L0 <- 500 zr <- -7 r <- 50 g <- xgrsr.crit(k, L0, zr=zr, r=r) DxDgrsr.arl <- Vectorize(xDgrsr.arl, "delta") deltas <- c(0.0001, 0.0005, 0.001, 0.002, 0.005, 0.01, 0.02, 0.05, 0.1, 0.5, 1, 3) arls <- round(DxDgrsr.arl(k, g, deltas, zr=zr, r=r), digits=4) data.frame(deltas, arls) } } \keyword{ts} spc/man/sewma.arl.Rd0000644000176200001440000000676713553640534014022 0ustar liggesusers\name{sewma.arl} \alias{sewma.arl} \title{Compute ARLs of EWMA control charts (variance charts)} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of EWMA control charts (based on the sample variance \eqn{S^2}) monitoring normal variance.} \usage{sewma.arl(l,cl,cu,sigma,df,s2.on=TRUE,hs=NULL,sided="upper",r=40,qm=30)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{cl}{lower control limit of the EWMA control chart.} \item{cu}{upper control limit of the EWMA control chart.} \item{sigma}{true standard deviation.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{s2.on}{distinguishes between \eqn{S^2}{S^2} and \eqn{S}{S} chart.} \item{hs}{so-called headstart (enables fast initial response); the default (\code{NULL}) yields the expected in-control value of \eqn{S^2}{S^2} (1) and \eqn{S}{S} (\eqn{c_4}{c_4}), respectively.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{r}{dimension of the resulting linear equation system (highest order of the collocation polynomials).} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} } \details{ \code{sewma.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of collocation (Chebyshev polynomials).} \value{Returns a single value which resembles the ARL.} \references{ S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2006), Computation of the ARL for CUSUM-\eqn{S^2}{S^2} schemes, \emph{Computational Statistics & Data Analysis 51}, 499-512. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL computation of EWMA control charts for monitoring normal mean. } \examples{ ## Knoth (2005) ## compare with Table 1 (p. 347): 249.9997 ## Monte Carlo with 10^9 replicates: 249.9892 +/- 0.008 l <- .025 df <- 1 cu <- 1 + 1.661865*sqrt(l/(2-l))*sqrt(2/df) sewma.arl(l,0,cu,1,df) ## ARL values for upper and lower EWMA charts with reflecting barriers ## (reflection at in-control level sigma0 = 1) ## examples from Knoth (2006), Tables 4 and 5 Ssewma.arl <- Vectorize("sewma.arl", "sigma") ## upper chart with reflection at sigma0=1 in Table 4 ## original entries are # sigma ARL # 1 100.0 # 1.01 85.3 # 1.02 73.4 # 1.03 63.5 # 1.04 55.4 # 1.05 48.7 # 1.1 27.9 # 1.2 12.9 # 1.3 7.86 # 1.4 5.57 # 1.5 4.30 # 2 2.11 \dontrun{ l <- 0.15 df <- 4 cu <- 1 + 2.4831*sqrt(l/(2-l))*sqrt(2/df) sigmas <- c(1 + (0:5)/100, 1 + (1:5)/10, 2) arls <- round(Ssewma.arl(l, 1, cu, sigmas, df, sided="Rupper", r=100), digits=2) data.frame(sigmas, arls)} ## lower chart with reflection at sigma0=1 in Table 5 ## original entries are # sigma ARL # 1 200.04 # 0.9 38.47 # 0.8 14.63 # 0.7 8.65 # 0.6 6.31 \dontrun{ l <- 0.115 df <- 5 cl <- 1 - 2.0613*sqrt(l/(2-l))*sqrt(2/df) sigmas <- c((10:6)/10) arls <- round(Ssewma.arl(l, cl, 1, sigmas, df, sided="Rlower", r=100), digits=2) data.frame(sigmas, arls)} } \keyword{ts} spc/man/xewma.q.prerun.Rd0000644000176200001440000001125113553640534015003 0ustar liggesusers\name{xewma.q.prerun} \alias{xewma.q.prerun} \alias{xewma.q.crit.prerun} \title{Compute RL quantiles of EWMA control charts in case of estimated parameters} \description{Computation of quantiles of the Run Length (RL) for EWMA control charts monitoring normal mean if the in-control mean, standard deviation, or both are estimated by a pre run.} \usage{xewma.q.prerun(l, c, mu, p, zr=0, hs=0, sided="two", limits="fix", q=1, size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, bound=1e-10) xewma.q.crit.prerun(l, L0, mu, p, zr=0, hs=0, sided="two", limits="fix", size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, bound=1e-10, c.error=1e-10, p.error=1e-9, OUTPUT=FALSE)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{mu}{true mean shift.} \item{p}{quantile level.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (give fast initial response).} \item{sided}{distinguish between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguish between different control limits behavior.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\geq)}, will be determined. Note that mu0=0 is implicitely fixed.} \item{size}{pre run sample size.} \item{df}{Degrees of freedom of the pre run variance estimator. Typically it is simply \code{size} - 1. If the pre run is collected in batches, then also other values are needed.} \item{estimated}{name the parameter to be estimated within the \code{"mu"}, \code{"sigma"}, \code{"both"}.} \item{qm.mu}{number of quadrature nodes for convoluting the mean uncertainty.} \item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.} \item{truncate}{size of truncated tail.} \item{bound}{control when the geometric tail kicks in; the larger the quicker and less accurate; \code{bound} should be larger than 0 and less than 0.001.} \item{L0}{in-control quantile value.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{p.error}{error bound for the quantile level \code{p} during applying the secant rule.} \item{OUTPUT}{activate or deactivate additional output.} } \details{ Essentially, the ARL function \code{xewma.q} is convoluted with the distribution of the sample mean, standard deviation or both. For details see Jones/Champ/Rigdon (2001) and Knoth (2014?). } \value{Returns a single value which resembles the RL quantile of order \code{q}.} \references{ L. A. Jones, C. W. Champ, S. E. Rigdon (2001), The performance of exponentially weighted moving average charts with estimated parameters, \emph{Technometrics 43}, 156-167. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. S. Knoth (2014?), tbd, \emph{tbd}, tbd-tbd. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{xewma.q} for the usual RL quantiles computation of EWMA control charts. } \examples{ ## Jones/Champ/Rigdon (2001) c4m <- function(m, n) sqrt(2)*gamma( (m*(n-1)+1)/2 )/sqrt( m*(n-1) )/gamma( m*(n-1)/2 ) n <- 5 # sample size m <- 20 # pre run with 20 samples of size n = 5 C4m <- c4m(m, n) # needed for bias correction # Table 1, 3rd column lambda <- 0.2 L <- 2.636 xewma.Q <- Vectorize("xewma.q", "mu") xewma.Q.prerun <- Vectorize("xewma.q.prerun", "mu") mu <- c(0, .25, .5, 1, 1.5, 2) Q1 <- ceiling(xewma.Q(lambda, L, mu, 0.1, sided="two")) Q2 <- ceiling(xewma.Q(lambda, L, mu, 0.5, sided="two")) Q3 <- ceiling(xewma.Q(lambda, L, mu, 0.9, sided="two")) cbind(mu, Q1, Q2, Q3) \dontrun{ p.Q1 <- xewma.Q.prerun(lambda, L/C4m, mu, 0.1, sided="two", size=m, df=m*(n-1), estimated="both") p.Q2 <- xewma.Q.prerun(lambda, L/C4m, mu, 0.5, sided="two", size=m, df=m*(n-1), estimated="both") p.Q3 <- xewma.Q.prerun(lambda, L/C4m, mu, 0.9, sided="two", size=m, df=m*(n-1), estimated="both") cbind(mu, p.Q1, p.Q2, p.Q3) } ## original values are # mu Q1 Q2 Q3 p.Q1 p.Q2 p.Q3 # 0.00 25 140 456 13 73 345 # 0.25 12 56 174 9 46 253 # 0.50 7 20 56 6 20 101 # 1.00 4 7 15 3 7 18 # 1.50 3 4 7 2 4 8 # 2.00 2 3 5 2 3 5 } \keyword{ts} spc/man/xsewma.crit.Rd0000644000176200001440000000726413553640534014366 0ustar liggesusers\name{xsewma.crit} \alias{xsewma.crit} \title{Compute critical values of simultaneous EWMA control charts (mean and variance charts)} \description{Computation of the critical values (similar to alarm limits) for different types of simultaneous EWMA control charts (based on the sample mean and the sample variance \eqn{S^2}) monitoring normal mean and variance.} \usage{xsewma.crit(lx, ls, L0, df, mu0=0, sigma0=1, cu=NULL, hsx=0, hss=1, s2.on=TRUE, sided="upper", mode="fixed", Nx=30, Ns=40, qm=30)} \arguments{ \item{lx}{smoothing parameter lambda of the two-sided mean EWMA chart.} \item{ls}{smoothing parameter lambda of the variance EWMA chart.} \item{L0}{in-control ARL.} \item{mu0}{in-control mean.} \item{sigma0}{in-control standard deviation.} \item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit (\code{mode}=\code{"fixed"}) a value larger than \code{sigma0} has to been given, for all other cases \code{cu} is ignored.} \item{hsx}{so-called headstart (enables fast initial response) of the mean chart -- do not confuse with the true FIR feature considered in xewma.arl; will be updated.} \item{hss}{headstart (enables fast initial response) of the variance chart.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{s2.on}{distinguishes between \eqn{S^2}{S^2} and \eqn{S}{S} chart.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit (see \code{cu}) is set and only the lower is determined to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated).} \item{Nx}{dimension of the approximating matrix of the mean chart.} \item{Ns}{dimension of the approximating matrix of the variance chart.} \item{qm}{number of quadrature nodes used for the collocation integrals.} } \details{ \code{xsewma.crit} determines the critical values (similar to alarm limits) for given in-control ARL \code{L0} by applying secant rule and using \code{xsewma.arl()}. In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"} a two-dimensional secant rule is applied that also ensures that the maximum of the ARL function for given standard deviation is attained at \code{sigma0}. See Knoth (2007) for details and application. } \value{Returns the critical value of the two-sided mean EWMA chart and the lower and upper controls limit \code{cl} and \code{cu} of the variance EWMA chart.} \references{ S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. } \author{Sven Knoth} \seealso{\code{xsewma.arl} for calculation of ARL of simultaneous EWMA charts.} \examples{ ## Knoth (2007) ## results in Table 2 # subgroup size n=5, df=n-1 df <- 4 # lambda of mean chart lx <- .134 # lambda of variance chart ls <- .1 # in-control ARL L0 <- 252.3 # matrix dimensions for mean and variance part Nx <- 25 Ns <- 25 # mode of variance chart SIDED <- "upper" crit <- xsewma.crit(lx, ls, L0, df, sided=SIDED, Nx=Nx, Ns=Ns) crit ## output as used in Knoth (2007) crit["cx"]/sqrt(df+1)*sqrt(lx/(2-lx)) crit["cu"] - 1 } \keyword{ts} spc/man/xshewhart.ar1.arl.Rd0000644000176200001440000000471213553640534015371 0ustar liggesusers\name{xshewhart.ar1.arl} \alias{xshewhart.ar1.arl} \title{Compute ARLs of modified Shewhart control charts for AR(1) data} \description{Computation of the (zero-state) Average Run Length (ARL) for modified Shewhart charts deployed to the original AR(1) data.} \usage{xshewhart.ar1.arl(alpha, cS, delta=0, N1=50, N2=30)} \arguments{ \item{alpha}{lag 1 correlation of the data.} \item{cS}{critical value (alias to alarm limit) of the Shewhart control chart.} \item{delta}{potential shift in the data (in-control mean is zero.} \item{N1}{number of quadrature nodes for solving the ARL integral equation, dimension of the resulting linear equation system is \code{N1}.} \item{N2}{second number of quadrature nodes for combining the probability density function of the first observation following the margin distribution and the solution of the ARL integral equation.} } \details{ Following the idea of Schmid (1995), \code{1- alpha} times the data turns out to be an EWMA smoothing of the underlying AR(1) residuals. Hence, by combining the solution of the EWMA ARL integral equation and the stationary distribution of the AR(1) data (normal distribution is assumed) one gets easily the overall ARL. } \value{It returns a single value resembling the zero-state ARL of a modified Shewhart chart.} \references{ S. Knoth, W. Schmid (2004). Control charts for time series: A review. In \emph{Frontiers in Statistical Quality Control 7}, edited by H.-J. Lenz, P.-T. Wilrich, 210-236, Physica-Verlag. H. Kramer, W. Schmid (2000). The influence of parameter estimation on the ARL of Shewhart type charts for time series. \emph{Statistical Papers 41}(2), 173-196. W. Schmid (1995). On the run length of a Shewhart chart for correlated data. \emph{Statistical Papers 36}(1), 111-130. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL computation of EWMA control charts. } \examples{ ## Table 1 in Kramer/Schmid (2000) cS <- 3.09023 a <- seq(0, 4, by=.5) row1 <- row2 <- row3 <- NULL for ( i in 1:length(a) ) { row1 <- c(row1, round(xshewhart.ar1.arl( 0.4, cS, delta=a[i]), digits=2)) row2 <- c(row2, round(xshewhart.ar1.arl( 0.2, cS, delta=a[i]), digits=2)) row3 <- c(row3, round(xshewhart.ar1.arl(-0.2, cS, delta=a[i]), digits=2)) } results <- rbind(row1, row2, row3) results # original values are # row1 515.44 215.48 61.85 21.63 9.19 4.58 2.61 1.71 1.29 # row2 502.56 204.97 56.72 19.13 7.95 3.97 2.33 1.59 1.25 # row3 502.56 201.41 54.05 17.42 6.89 3.37 2.03 1.46 1.20 } \keyword{ts} spc/man/sewma.arl.prerun.Rd0000644000176200001440000000501613553640534015316 0ustar liggesusers\name{sewma.arl.prerun} \alias{sewma.arl.prerun} \title{Compute ARLs of EWMA control charts (variance charts) in case of estimated parameters} \description{Computation of the (zero-state) Average Run Length (ARL) for EWMA control charts (based on the sample variance \eqn{S^2}) monitoring normal variance with estimated parameters.} \usage{sewma.arl.prerun(l, cl, cu, sigma, df1, df2, hs=1, sided="upper", r=40, qm=30, qm.sigma=30, truncate=1e-10)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{cl}{lower control limit of the EWMA control chart.} \item{cu}{upper control limit of the EWMA control chart.} \item{sigma}{true standard deviation.} \item{df1}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{df2}{degrees of freedom of the pre-run variance estimator.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}),\code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{r}{dimension of the resulting linear equation system (highest order of the collocation polynomials).} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} \item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.} \item{truncate}{size of truncated tail.} } \details{ Essentially, the ARL function \code{sewma.arl} is convoluted with the distribution of the sample standard deviation. For details see Jones/Champ/Rigdon (2001) and Knoth (2014?).} \value{Returns a single value which resembles the ARL.} \references{ L. A. Jones, C. W. Champ, S. E. Rigdon (2001), The performance of exponentially weighted moving average charts with estimated parameters, \emph{Technometrics 43}, 156-167. S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2006), Computation of the ARL for CUSUM-\eqn{S^2}{S^2} schemes, \emph{Computational Statistics & Data Analysis 51}, 499-512. } \author{Sven Knoth} \seealso{ \code{sewma.arl} for zero-state ARL function of EWMA control charts w/o pre run uncertainty. } \examples{ ## will follow } \keyword{ts} spc/man/xsewma.sf.Rd0000644000176200001440000000552313553640534014031 0ustar liggesusers\name{xsewma.sf} \alias{xsewma.sf} \title{Compute the survival function of simultaneous EWMA control charts (mean and variance charts)} \description{Computation of the survival function of the Run Length (RL) for EWMA control charts monitoring simultaneously normal mean and variance.} \usage{xsewma.sf(n, lx, cx, ls, csu, df, mu, sigma, hsx=0, Nx=40, csl=0, hss=1, Ns=40, sided="upper", qm=30) } \arguments{ \item{n}{calculate sf up to value \code{n}.} \item{lx}{smoothing parameter lambda of the two-sided mean EWMA chart.} \item{cx}{control limit of the two-sided mean EWMA control chart.} \item{ls}{smoothing parameter lambda of the variance EWMA chart.} \item{csu}{upper control limit of the variance EWMA control chart.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{mu}{true mean.} \item{sigma}{true standard deviation.} \item{hsx}{so-called headstart (enables fast initial response) of the mean chart -- do not confuse with the true FIR feature considered in xewma.arl; will be updated.} \item{Nx}{dimension of the approximating matrix of the mean chart.} \item{csl}{lower control limit of the variance EWMA control chart; default value is 0; not considered if \code{sided} is \code{"upper"}.} \item{hss}{headstart (enables fast initial response) of the variance chart.} \item{Ns}{dimension of the approximating matrix of the variance chart.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{qm}{number of quadrature nodes used for the collocation integrals.} } \details{ The survival function P(L>n) and derived from it also the cdf P(L<=n) and the pmf P(L=n) illustrate the distribution of the EWMA run length. For large n the geometric tail could be exploited. That is, with reasonable large n the complete distribution is characterized. The algorithm is based on Waldmann's survival function iteration procedure and on results in Knoth (2007). } \value{Returns a vector which resembles the survival function up to a certain point.} \references{ S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{xsewma.arl} for zero-state ARL computation of simultaneous EWMA control charts. } \examples{ ## will follow } \keyword{ts} spc/man/sewma.crit.Rd0000644000176200001440000001443213553640534014171 0ustar liggesusers\name{sewma.crit} \alias{sewma.crit} \title{Compute critical values of EWMA control charts (variance charts)} \description{Computation of the critical values (similar to alarm limits) for different types of EWMA control charts (based on the sample variance \eqn{S^2}) monitoring normal variance.} \usage{sewma.crit(l,L0,df,sigma0=1,cl=NULL,cu=NULL,hs=NULL,s2.on=TRUE, sided="upper",mode="fixed",ur=4,r=40,qm=30)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{L0}{in-control ARL.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{sigma0}{in-control standard deviation.} \item{cl}{deployed for \code{sided}=\code{"Rupper"}, that is, upper variance control chart with lower reflecting barrier \code{cl}.} \item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit (\code{mode}=\code{"fixed"}) a value larger than \code{sigma0} has to been given, for all other cases \code{cu} is ignored.} \item{hs}{so-called headstart (enables fast initial response); the default (\code{NULL}) yields the expected in-control value of \eqn{S^2}{S^2} (1) and \eqn{S}{S} (\eqn{c_4}{c_4}), respectively.} \item{s2.on}{distinguishes between \eqn{S^2}{S^2} and \eqn{S}{S} chart.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit (see \code{cu}) is set and only the lower is calculated to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated). With \code{"vanilla"} limits symmetric around 1 (the in-control value of the variance) are determined, while for \code{"eq.tails"} the in-control ARL values of two single EWMA variance charts (decompose the two-sided scheme into one lower and one upper scheme) are matched.} \item{ur}{truncation of lower chart for \code{eq.tails} mode.} \item{r}{dimension of the resulting linear equation system (highest order of the collocation polynomials).} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} } \details{ \code{sewma.crit} determines the critical values (similar to alarm limits) for given in-control ARL \code{L0} by applying secant rule and using \code{sewma.arl()}. In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"} a two-dimensional secant rule is applied that also ensures that the maximum of the ARL function for given standard deviation is attained at \code{sigma0}. See Knoth (2010) and the related example. } \value{Returns the lower and upper control limit \code{cl} and \code{cu}.} \references{ H.-J. Mittag and D. Stemann and B. Tewes (1998), EWMA-Karten zur \"Uberwachung der Streuung von Qualit\"atsmerkmalen, \emph{Allgemeines Statistisches Archiv 82}, 327-338, C. A. Acosta-Mej\'ia and J. J. Pignatiello Jr. and B. V. Rao (1999), A comparison of control charting procedures for monitoring process dispersion, \emph{IIE Transactions 31}, 569-579. S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2006a), Computation of the ARL for CUSUM-\eqn{S^2}{S^2} schemes, \emph{Computational Statistics & Data Analysis 51}, 499-512. S. Knoth (2006b), The art of evaluating monitoring schemes -- how to measure the performance of control charts? in \emph{Frontiers in Statistical Quality Control 8}, H.-J. Lenz and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 74-99. S. Knoth (2010), Control Charting Normal Variance -- Reflections, Curiosities, and Recommendations, in \emph{Frontiers in Statistical Quality Control 9}, H.-J. Lenz and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 3-18. } \author{Sven Knoth} \seealso{\code{sewma.arl} for calculation of ARL of variance charts.} \examples{ ## Mittag et al. (1998) ## compare their upper critical value 2.91 that ## leads to the upper control limit via the formula shown below ## (for the usual upper EWMA \eqn{S^2}{S^2}). ## See Knoth (2006b) for a discussion of this EWMA setup and it's evaluation. l <- 0.18 L0 <- 250 df <- 4 limits <- sewma.crit(l, L0, df) limits["cu"] limits.cu.mittag_et_al <- 1 + sqrt(l/(2-l))*sqrt(2/df)*2.91 limits.cu.mittag_et_al ## Knoth (2005) ## reproduce the critical value given in Figure 2 (c=1.661865) for ## upper EWMA \eqn{S^2}{S^2} with df=1 l <- 0.025 L0 <- 250 df <- 1 limits <- sewma.crit(l, L0, df) cv.Fig2 <- (limits["cu"]-1)/( sqrt(l/(2-l))*sqrt(2/df) ) cv.Fig2 ## the small difference (sixth digit after decimal point) stems from ## tighter criterion in the secant rule implemented in the R package. ## demo of unbiased ARL curves ## Deploy, please, not matrix dimensions smaller than 50 -- for the ## sake of accuracy, the value 80 was used. ## Additionally, this example needs between 1 and 2 minutes on a 1.6 Ghz box. \dontrun{ l <- 0.1 L0 <- 500 df <- 4 limits <- sewma.crit(l, L0, df, sided="two", mode="unbiased", r=80) SEWMA.arl <- Vectorize(sewma.arl, "sigma") SEWMA.ARL <- function(sigma) SEWMA.arl(l, limits[1], limits[2], sigma, df, sided="two", r=80) layout(matrix(1:2, nrow=1)) curve(SEWMA.ARL, .75, 1.25, log="y") curve(SEWMA.ARL, .95, 1.05, log="y")} # the above stuff needs about 1 minute ## control limits for upper and lower EWMA charts with reflecting barriers ## (reflection at in-control level sigma0 = 1) ## examples from Knoth (2006a), Tables 4 and 5 \dontrun{ ## upper chart with reflection at sigma0=1 in Table 4: c = 2.4831 l <- 0.15 L0 <- 100 df <- 4 limits <- sewma.crit(l, L0, df, cl=1, sided="Rupper", r=100) cv.Tab4 <- (limits["cu"]-1)/( sqrt(l/(2-l))*sqrt(2/df) ) cv.Tab4 ## lower chart with reflection at sigma0=1 in Table 5: c = 2.0613 l <- 0.115 L0 <- 200 df <- 5 limits <- sewma.crit(l, L0, df, cu=1, sided="Rlower", r=100) cv.Tab5 <- -(limits["cl"]-1)/( sqrt(l/(2-l))*sqrt(2/df) ) cv.Tab5} } \keyword{ts} spc/man/xcusum.crit.L0h.Rd0000644000176200001440000000343013553640534015017 0ustar liggesusers\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/mewma.arl.Rd0000644000176200001440000002173613553640534014005 0ustar liggesusers\name{mewma.arl} \alias{mewma.arl} \alias{mewma.arl.f} \alias{mewma.ad} \title{Compute ARLs of MEWMA control charts} \description{Computation of the (zero-state) Average Run Length (ARL) for multivariate exponentially weighted moving average (MEWMA) charts monitoring multivariate normal mean.} \usage{mewma.arl(l, cE, p, delta=0, hs=0, r=20, ntype=NULL, qm0=20, qm1=qm0) mewma.arl.f(l, cE, p, delta=0, r=20, ntype=NULL, qm0=20, qm1=qm0) mewma.ad(l, cE, p, delta=0, r=20, n=20, type="cond", hs=0, ntype=NULL, qm0=20, qm1=qm0)} \arguments{ \item{l}{smoothing parameter lambda of the MEWMA control chart.} \item{cE}{alarm threshold of the MEWMA control chart.} \item{p}{dimension of multivariate normal distribution.} \item{delta}{magnitude of the potential change, \code{delta=0} refers to the in-control state.} \item{hs}{so-called headstart (enables fast initial response) -- must be non-negative.} \item{r}{number of quadrature nodes -- dimension of the resulting linear equation system for \code{delta} = 0. For non-zero \code{delta} this dimension is mostly r^2 (Markov chain approximation leads to some larger values). Caution: If \code{ntype} is set to \code{"co"} (collocation), then values of \code{r} larger than 20 lead to large computing times. For the other selections this would happen for values larger than 40.} \item{ntype}{choose the numerical algorithm to solve the ARL integral equation. For \code{delta}=0: Possible values are \code{"gl"}, \code{"gl2"} (gauss-legendre, classic and with variables change: square), \code{"co"} (collocation, for \code{delta} > 0 with sin transformation), \code{"ra"} (radau), \code{"cc"} (clenshaw-curtis), \code{"mc"} (markov chain), and \code{"sr"} (simpson rule). For \code{delta} larger than 0, some more values besides the others are possible: \code{"gl3"}, \code{"gl4"}, \code{"gl5"} (gauss-legendre with a further change in variables: sin, tan, sinh), \code{"co2"}, \code{"co3"} (collocation with some trimming and tan as quadrature stabilizing transformations, respectively). If it is set to \code{NULL} (the default), then for \code{delta}=0 then \code{"gl2"} is chosen. If \code{delta} larger than 0, then for \code{p} equal 2 or 4 \code{"gl3"} and for all other values \code{"gl5"} is taken. \code{"ra"} denotes the method used in Rigdon (1995a). \code{"mc"} denotes the Markov chain approximation.} \item{type}{switch between \code{"cond"} and \code{"cycl"} for differentiating between the conditional (no false alarm) and the cyclical (after false alarm re-start in \code{hs}), respectively.} \item{n}{number of quadrature nodes for Calculating the steady-state ARL integral(s).} \item{qm0,qm1}{number of collocation quadrature nodes for the out-of-control case (\code{qm0} for the inner integral, \code{qm1} for the outer one), that is, for positive \code{delta}, and for the in-control case (now only \code{qm0} is deployed) if via \code{ntype} the collocation procedure is requested.} } \details{Basically, this is the implementation of different numerical algorithms for solving the integral equation for the MEWMA in-control (\code{delta} = 0) ARL introduced in Rigdon (1995a) and out-of-control (\code{delta} != 0) ARL in Rigdon (1995b). Most of them are nothing else than the Nystroem approach -- the integral is replaced by a suitable quadrature. Here, the Gauss-Legendre (more powerful), Radau (used by Rigdon, 1995a), Clenshaw-Curtis, and Simpson rule (which is really bad) are provided. Additionally, the collocation approach is offered as well, because it is much better for small odd values for \code{p}. FORTRAN code for the Radau quadrature based Nystroem of Rigdon (1995a) was published in Bodden and Rigdon (1999) -- see also \url{http://lib.stat.cmu.edu/jqt/31-1}. Furthermore, FORTRAN code for the Markov chain approximation (in- and out-ot-control) could be found at %\url{http://lib.stat.cmu.edu/jqt/33-4}. http://lib.stat.cmu.edu/jqt/33-4. The related papers are Runger and Prabhu (1996) and Molnau et al. (2001). The idea of the Clenshaw-Curtis quadrature was taken from Capizzi and Masarotto (2010), who successfully deployed a modified Clenshaw-Curtis quadrature to calculate the ARL of combined (univariate) Shewhart-EWMA charts. It turns out that it works also nicely for the MEWMA ARL. The version \code{mewma.arl.f()} without the argument \code{hs} provides the ARL as function of one (in-control) or two (out-of-control) arguments. } \value{Returns a single value which is simply the zero-state ARL.} \references{ Kevin M. Bodden and Steven E. Rigdon (1999), A program for approximating the in-control ARL for the MEWMA chart, \emph{Journal of Quality Technology 31(1)}, 120-123. Giovanna Capizzi and Guido Masarotto (2010), Evaluation of the run-length distribution for a combined Shewhart-EWMA control chart, \emph{Statistics and Computing 20(1)}, 23-33. Sven Knoth (2017), ARL Numerics for MEWMA Charts, \emph{Journal of Quality Technology 49(1)}, 78-89. Wade E. Molnau et al. (2001), A Program for ARL Calculation for Multivariate EWMA Charts, \emph{Journal of Quality Technology 33(4)}, 515-521. Sharad S. Prabhu and George C. Runger (1997), Designing a multivariate EWMA control chart, \emph{Journal of Quality Technology 29(1)}, 8-15. Steven E. Rigdon (1995a), An integral equation for the in-control average run length of a multivariate exponentially weighted moving average control chart, \emph{J. Stat. Comput. Simulation 52(4)}, 351-365. Steven E. Rigdon (1995b), A double-integral equation for the average run length of a multivariate exponentially weighted moving average control chart, \emph{Stat. Probab. Lett. 24(4)}, 365-373. George C. Runger and Sharad S. Prabhu (1996), A Markov Chain Model for the Multivariate Exponentially Weighted Moving Averages Control Chart, \emph{J. Amer. Statist. Assoc. 91(436)}, 1701-1706. } \author{Sven Knoth} \seealso{ \code{mewma.crit} for getting the alarm threshold to attain a certain in-control ARL. } \examples{ # Rigdon (1995a), p. 357, Tab. 1 p <- 2 r <- 0.25 h4 <- c(8.37, 9.90, 11.89, 13.36, 14.82, 16.72) for ( i in 1:length(h4) ) cat(paste(h4[i], "\t", round(mewma.arl(r, h4[i], p, ntype="ra")), "\n")) r <- 0.1 h4 <- c(6.98, 8.63, 10.77, 12.37, 13.88, 15.88) for ( i in 1:length(h4) ) cat(paste(h4[i], "\t", round(mewma.arl(r, h4[i], p, ntype="ra")), "\n")) # Rigdon (1995b), p. 372, Tab. 1 \dontrun{ r <- 0.1 p <- 4 h <- 12.73 for ( sdelta in c(0, 0.125, 0.25, .5, 1, 2, 3) ) cat(paste(sdelta, "\t", round(mewma.arl(r, h, p, delta=sdelta^2, ntype="ra", r=25), digits=2), "\n")) p <- 5 h <- 14.56 for ( sdelta in c(0, 0.125, 0.25, .5, 1, 2, 3) ) cat(paste(sdelta, "\t", round(mewma.arl(r, h, p, delta=sdelta^2, ntype="ra", r=25), digits=2), "\n")) p <- 10 h <- 22.67 for ( sdelta in c(0, 0.125, 0.25, .5, 1, 2, 3) ) cat(paste(sdelta, "\t", round(mewma.arl(r, h, p, delta=sdelta^2, ntype="ra", r=25), digits=2), "\n")) } # Runger/Prabhu (1996), p. 1704, Tab. 1 \dontrun{ r <- 0.1 p <- 4 H <- 12.73 cat(paste(0, "\t", round(mewma.arl(r, H, p, delta=0, ntype="mc", r=50), digits=2), "\n")) for ( delta in c(.5, 1, 1.5, 2, 3) ) cat(paste(delta, "\t", round(mewma.arl(r, H, p, delta=delta, ntype="mc", r=25), digits=2), "\n")) # compare with Fortran program (MEWMA-ARLs.f90) from Molnau et al. (2001) with m1 = m2 = 25 # H4 P R DEL ARL # 12.73 4. 0.10 0.00 199.78 # 12.73 4. 0.10 0.50 35.05 # 12.73 4. 0.10 1.00 12.17 # 12.73 4. 0.10 1.50 7.22 # 12.73 4. 0.10 2.00 5.19 # 12.73 4. 0.10 3.00 3.42 p <- 20 H <- 37.01 cat(paste(0, "\t", round(mewma.arl(r, H, p, delta=0, ntype="mc", r=50), digits=2), "\n")) for ( delta in c(.5, 1, 1.5, 2, 3) ) cat(paste(delta, "\t", round(mewma.arl(r, H, p, delta=delta, ntype="mc", r=25), digits=2), "\n")) # compare with Fortran program (MEWMA-ARLs.f90) from Molnau et al. (2001) with m1 = m2 = 25 # H4 P R DEL ARL # 37.01 20. 0.10 0.00 199.09 # 37.01 20. 0.10 0.50 61.62 # 37.01 20. 0.10 1.00 20.17 # 37.01 20. 0.10 1.50 11.40 # 37.01 20. 0.10 2.00 8.03 # 37.01 20. 0.10 3.00 5.18 } # Knoth (2017), p. 85, Tab. 3, rows with p=3 \dontrun{ p <- 3 lambda <- 0.05 h4 <- mewma.crit(lambda, 200, p) benchmark <- mewma.arl(lambda, h4, p, delta=1, r=50) mc.arl <- mewma.arl(lambda, h4, p, delta=1, r=25, ntype="mc") ra.arl <- mewma.arl(lambda, h4, p, delta=1, r=27, ntype="ra") co.arl <- mewma.arl(lambda, h4, p, delta=1, r=12, ntype="co2") gl3.arl <- mewma.arl(lambda, h4, p, delta=1, r=30, ntype="gl3") gl5.arl <- mewma.arl(lambda, h4, p, delta=1, r=25, ntype="gl5") abs( benchmark - data.frame(mc.arl, ra.arl, co.arl, gl3.arl, gl5.arl) ) } # Prabhu/Runger (1997), p. 13, Tab. 3 \dontrun{ p <- 2 r <- 0.1 H <- 8.64 cat(paste(0, "\t", round(mewma.ad(r, H, p, delta=0, type="cycl", ntype="mc", r=60), digits=2), "\n")) for ( delta in c(.5, 1, 1.5, 2, 3) ) cat(paste(delta, "\t", round(mewma.ad(r, H, p, delta=delta, type="cycl", ntype="mc", r=30), digits=2), "\n")) # better accuracy for ( delta in c(0, .5, 1, 1.5, 2, 3) ) cat(paste(delta, "\t", round(mewma.ad(r, H, p, delta=delta^2, type="cycl", r=30), digits=2), "\n")) } } \keyword{ts} spc/man/sewma.q.prerun.Rd0000644000176200001440000001003513553640534014775 0ustar liggesusers\name{sewma.q.prerun} \alias{sewma.q.prerun} \alias{sewma.q.crit.prerun} \title{Compute RL quantiles of EWMA (variance charts) control charts under pre-run uncertainty} \description{Computation of quantiles of the Run Length (RL) for EWMA control charts monitoring normal variance.} \usage{sewma.q.prerun(l,cl,cu,sigma,df1,df2,alpha,hs=1,sided="upper", r=40,qm=30,qm.sigma=30,truncate=1e-10) sewma.q.crit.prerun(l,L0,alpha,df1,df2,sigma0=1,cl=NULL,cu=NULL,hs=1, sided="upper",mode="fixed",r=40, qm=30,qm.sigma=30,truncate=1e-10, tail_approx=TRUE,c.error=1e-10,a.error=1e-9)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{cl}{deployed for \code{sided}=\code{"Rupper"}, that is, upper variance control chart with lower reflecting barrier \code{cl}.} \item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit (\code{mode}=\code{"fixed"}) a value larger than \code{sigma0} has to been given, for all other cases \code{cu} is ignored.} \item{sigma,sigma0}{true and in-control standard deviation, respectively.} \item{L0}{in-control quantile value.} \item{alpha}{quantile level.} \item{df1}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{df2}{degrees of freedom of the pre-run variance estimator.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit (see \code{cu}) is set and only the lower is calculated to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated).} \item{r}{dimension of the resulting linear equation system (highest order of the collocation polynomials).} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} \item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.} \item{truncate}{size of truncated tail.} \item{tail_approx}{controls whether the geometric tail approximation is used (is faster) or not.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{a.error}{error bound for the quantile level \code{alpha} during applying the secant rule.} } \details{ Instead of the popular ARL (Average Run Length) quantiles of the EWMA stopping time (Run Length) are determined. The algorithm is based on Waldmann's survival function iteration procedure. Thereby the ideas presented in Knoth (2007) are used. \code{sewma.q.crit.prerun} determines the critical values (similar to alarm limits) for given in-control RL quantile \code{L0} at level \code{alpha} by applying secant rule and using \code{sewma.sf()}. In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"} a two-dimensional secant rule is applied that also ensures that the minimum of the cdf for given standard deviation is attained at \code{sigma0}. } \value{Returns a single value which resembles the RL quantile of order \code{alpha} and the lower and upper control limit \code{cl} and \code{cu}, respectively.} \references{ S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{\code{sewma.q} and \code{sewma.q.crit} for the version w/o pre-run uncertainty.} \examples{ ## will follow } \keyword{ts} spc/man/xgrsr.crit.Rd0000644000176200001440000000420113553640534014213 0ustar liggesusers\name{xgrsr.crit} \alias{xgrsr.crit} \title{Compute alarm thresholds for Shiryaev-Roberts schemes} \description{Computation of the alarm thresholds (alarm limits) for Shiryaev-Roberts schemes monitoring normal mean.} \usage{xgrsr.crit(k, L0, mu0 = 0, zr = 0, hs = NULL, sided = "one", MPT = FALSE, r = 30)} \arguments{ \item{k}{reference value of the Shiryaev-Roberts scheme.} \item{L0}{in-control ARL.} \item{mu0}{in-control mean.} \item{zr}{reflection border to enable the numerical algorithms used here.} \item{hs}{so-called headstart (enables fast initial response). If \code{hs=NULL}, then the classical headstart -Inf is used (corresponds to 0 for the non-log scheme).} \item{sided}{distinguishes between one- and two-sided schemes by choosing \code{"one"} and\code{"two"}, respectively. Currently only one-sided schemes are implemented.} \item{MPT}{switch between the old implementation (\code{FALSE}) and the new one (\code{TRUE}) that considers the completed likelihood ratio. MPT contains the initials of G. Moustakides, A. Polunchenko and A. Tartakovsky.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1}.} } \details{ \code{xgrsr.crit} determines the alarm threshold (alarm limit) for given in-control ARL \code{L0} by applying secant rule and using \code{xgrsr.arl()}. } \value{Returns a single value which resembles the alarm limit \code{g}.} \references{ G. Moustakides, A. Polunchenko, A. Tartakovsky (2009), Numerical comparison of CUSUM and Shiryaev-Roberts procedures for detecting changes in distributions, \emph{Communications in Statistics: Theory and Methods 38}, 3225-3239.r. } \author{Sven Knoth} \seealso{\code{xgrsr.arl} for zero-state ARL computation.} \examples{ ## Table 4 from Moustakides et al. (2009) ## original values are # gamma/L0 A/exp(g) # 50 28.02 # 100 56.04 # 500 280.19 # 1000 560.37 # 5000 2801.75 # 10000 5603.7 theta <- 1 zr <- -6 r <- 100 Lxgrsr.crit <- Vectorize("xgrsr.crit", "L0") L0s <- c(50, 100, 500, 1000, 5000, 10000) gs <- Lxgrsr.crit(theta/2, L0s, zr=zr, r=r) data.frame(L0s, gs, A=round(exp(gs), digits=2)) } \keyword{ts} spc/man/lns2sewma.arl.Rd0000644000176200001440000000674313553640534014613 0ustar liggesusers\name{lns2ewma.arl} \alias{lns2ewma.arl} \title{Compute ARLs of EWMA ln \eqn{S^2}{S^2} control charts (variance charts)} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of EWMA control charts (based on the log of the sample variance \eqn{S^2}) monitoring normal variance.} \usage{lns2ewma.arl(l,cl,cu,sigma,df,hs=NULL,sided="upper",r=40)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{cl}{lower control limit of the EWMA control chart.} \item{cu}{upper control limit of the EWMA control chart.} \item{sigma}{true standard deviation.} \item{df}{actual degrees of freedom, corresponds to subsample size (for known mean it is equal to the subsample size, for unknown mean it is equal to subsample size minus one.} \item{hs}{so-called headstart (enables fast initial response) -- the default value (hs=NULL) corresponds to the in-control mean of ln \eqn{S^2}{S^2}.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart with reflection at \code{cl}), \code{"lower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{r}{dimension of the resulting linear equation system: the larger the better.} } \details{ \code{lns2ewma.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature.} \value{Returns a single value which resembles the ARL.} \references{ S. V. Crowder and M. D. Hamilton (1992), An EWMA for monitoring a process standard deviation, \emph{Journal of Quality Technology 24}, 12-21. S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL computation of EWMA control charts for monitoring normal mean. } \examples{ lns2ewma.ARL <- Vectorize("lns2ewma.arl", "sigma") ## Crowder/Hamilton (1992) ## moments of ln S^2 E_log_gamma <- function(df) log(2/df) + digamma(df/2) V_log_gamma <- function(df) trigamma(df/2) E_log_gamma_approx <- function(df) -1/df - 1/3/df^2 + 2/15/df^4 V_log_gamma_approx <- function(df) 2/df + 2/df^2 + 4/3/df^3 - 16/15/df^5 ## results from Table 3 ( upper chart with reflection at 0 = log(sigma0=1) ) ## original entries are (lambda = 0.05, K = 1.06, df=n-1=4) # sigma ARL # 1 200 # 1.1 43 # 1.2 18 # 1.3 11 # 1.4 7.6 # 1.5 6.0 # 2 3.2 df <- 4 lambda <- .05 K <- 1.06 cu <- K * sqrt( lambda/(2-lambda) * V_log_gamma_approx(df) ) sigmas <- c(1 + (0:5)/10, 2) arls <- round(lns2ewma.ARL(lambda, 0, cu, sigmas, df, hs=0, sided="upper"), digits=1) data.frame(sigmas, arls) ## Knoth (2005) ## compare with Table 3 (p. 351) lambda <- .05 df <- 4 K <- 1.05521 cu <- 1.05521 * sqrt( lambda/(2-lambda) * V_log_gamma_approx(df) ) ## upper chart with reflection at sigma0=1 in Table 4 ## original entries are # sigma ARL_0 ARL_-.267 # 1 200.0 200.0 # 1.1 43.04 41.55 # 1.2 18.10 19.92 # 1.3 10.75 13.11 # 1.4 7.63 9.93 # 1.5 5.97 8.11 # 2 3.17 4.67 M <- -0.267 cuM <- lns2ewma.crit(lambda, 200, df, cl=M, hs=M, r=60)[2] arls1 <- round(lns2ewma.ARL(lambda, 0, cu, sigmas, df, hs=0, sided="upper"), digits=2) arls2 <- round(lns2ewma.ARL(lambda, M, cuM, sigmas, df, hs=M, sided="upper", r=60), digits=2) data.frame(sigmas, arls1, arls2) } \keyword{ts} spc/man/xewma.ad.Rd0000644000176200001440000000600113553640534013612 0ustar liggesusers\name{xewma.ad} \alias{xewma.ad} \title{Compute steady-state ARLs of EWMA control charts} \description{Computation of the steady-state Average Run Length (ARL) for different types of EWMA control charts monitoring normal mean.} \usage{xewma.ad(l, c, mu1, mu0=0, zr=0, z0=0, sided="one", limits="fix", steady.state.mode="conditional", r=40)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{mu1}{out-of-control mean.} \item{mu0}{in-control mean.} \item{zr}{reflection border for the one-sided chart.} \item{z0}{restarting value of the EWMA sequence in case of a false alarm in \code{steady.state.mode="cyclical"}.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different control limits behavior.} \item{steady.state.mode}{distinguishes between two steady-state modes -- conditional and cyclical.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} } \details{ \code{xewma.ad} determines the steady-state Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature and using the power method for deriving the largest in magnitude eigenvalue and the related left eigenfunction. } \value{Returns a single value which resembles the steady-state ARL.} \references{ R. B. Crosier (1986), A new two-sided cumulative quality control scheme, \emph{Technometrics 28}, 187-194. S. V. Crowder (1987), A simple method for studying run-length distributions of exponentially weighted moving average charts, \emph{Technometrics 29}, 401-407. J. M. Lucas and M. S. Saccucci (1990), Exponentially weighted moving average control schemes: Properties and enhancements, \emph{Technometrics 32}, 1-12. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL computation and \code{xcusum.ad} for the steady-state ARL of CUSUM control charts. } \examples{ ## comparison of zero-state (= worst case ) and steady-state performance ## for two-sided EWMA control charts l <- .1 c <- xewma.crit(l,500,sided="two") mu <- c(0,.5,1,1.5,2) arl <- sapply(mu,l=l,c=c,sided="two",xewma.arl) ad <- sapply(mu,l=l,c=c,sided="two",xewma.ad) round(cbind(mu,arl,ad),digits=2) ## Lucas/Saccucci (1990) ## two-sided EWMA ## with fixed limits l1 <- .5 l2 <- .03 c1 <- 3.071 c2 <- 2.437 mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,3.5,4,5) ad1 <- sapply(mu,l=l1,c=c1,sided="two",xewma.ad) ad2 <- sapply(mu,l=l2,c=c2,sided="two",xewma.ad) round(cbind(mu,ad1,ad2),digits=2) ## original results are (in Table 3) ## 0.00 499. 480. ## 0.25 254. 74.1 ## 0.50 88.4 28.6 ## 0.75 35.7 17.3 ## 1.00 17.3 12.5 ## 1.50 6.44 8.00 ## 2.00 3.58 5.95 ## 2.50 2.47 4.78 ## 3.00 1.91 4.02 ## 3.50 1.58 3.49 ## 4.00 1.36 3.09 ## 5.00 1.10 2.55 } \keyword{ts} spc/man/scusum.crit.Rd0000644000176200001440000000516413553640534014376 0ustar liggesusers\name{scusum.crit} \alias{scusum.crit} \title{Compute decision intervals of CUSUM control charts (variance charts)} \description{omputation of the decision intervals (alarm limits) for different types of CUSUM control charts (based on the sample variance \eqn{S^2}) monitoring normal variance.} \usage{scusum.crit(k, L0, sigma, df, hs=0, sided="upper", mode="eq.tails", k2=NULL, hs2=0, r=40, qm=30)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{L0}{in-control ARL.} \item{sigma}{true standard deviation.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided CUSUM-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart), \code{"lower"} (lower chart), and \code{"two"} (two-sided chart), respectively. Note that for the two-sided chart the parameters \code{"k2"} and \code{"h2"} have to be set too.} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"eq.tails"} two one-sided CUSUM charts (lower and upper) with the same in-control ARL are coupled. With \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated).} \item{k2}{in case of a two-sided CUSUM chart for variance the reference value of the lower chart.} \item{hs2}{in case of a two-sided CUSUM chart for variance the headstart of the lower chart.} \item{r}{Dimension of the resulting linear equation system (highest order of the collocation polynomials times number of intervals -- see Knoth 2006).} \item{qm}{Number of quadrature nodes for calculating the collocation definite integrals.} } \details{ \code{scusum.crit} ddetermines the decision interval (alarm limit) for given in-control ARL \code{L0} by applying secant rule and using \code{scusum.arl()}.} \value{Returns a single value which resembles the decision interval \code{h}.} \references{ S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2006), Computation of the ARL for CUSUM-\eqn{S^2}{S^2} schemes, \emph{Computational Statistics & Data Analysis 51}, 499-512. } \author{Sven Knoth} \seealso{ \code{xcusum.arl} for zero-state ARL computation of CUSUM control charts monitoring normal mean. } \examples{ ## Knoth (2006) ## compare with Table 1 (p. 507) k <- 1.46 # sigma1 = 1.5 df <- 1 L0 <- 260.74 h <- scusum.crit(k, L0, 1, df) h # original value is 10 } \keyword{ts} spc/man/xtshewhart.ar1.arl.Rd0000644000176200001440000000524313553640534015555 0ustar liggesusers\name{xtshewhart.ar1.arl} \alias{xtshewhart.ar1.arl} \title{Compute ARLs of modified Shewhart control charts for AR(1) data with Student t residuals} \description{Computation of the (zero-state) Average Run Length (ARL) for modified Shewhart charts deployed to the original AR(1) data where the residuals follow a Student t distribution.} \usage{xtshewhart.ar1.arl(alpha, cS, df, delta=0, N1=50, N2=30, N3=2*N2, INFI=10, mode="tan")} \arguments{ \item{alpha}{lag 1 correlation of the data.} \item{cS}{critical value (alias to alarm limit) of the Shewhart control chart.} \item{df}{degrees of freedom -- parameter of the t distribution.} \item{delta}{potential shift in the data (in-control mean is zero.} \item{N1}{number of quadrature nodes for solving the ARL integral equation, dimension of the resulting linear equation system is \code{N1}.} \item{N2}{second number of quadrature nodes for combining the probability density function of the first observation following the margin distribution and the solution of the ARL integral equation.} \item{N3}{third number of quadrature nodes for solving the left eigenfunction integral equation to determine the margin density (see Andel/Hrach, 2000), dimension of the resulting linear equation system is \code{N3}.} \item{INFI}{substitute of \code{Inf} -- the left eigenfunction integral equation is defined on the whole real axis; now it is reduced to \code{(-INFI,INFI)}.} \item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently, \code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.} } \details{ Following the idea of Schmid (1995), \code{1-alpha} times the data turns out to be an EWMA smoothing of the underlying AR(1) residuals. Hence, by combining the solution of the EWMA ARL integral equation and the stationary distribution of the AR(1) data (here Student t distribution is assumed) one gets easily the overall ARL. } \value{It returns a single value resembling the zero-state ARL of a modified Shewhart chart.} \references{ J. Andel, K. Hrach (2000). On calculation of stationary density of autoregressive processes. \emph{Kybernetika, Institute of Information Theory and Automation AS CR 36}(3), 311-319. H. Kramer, W. Schmid (2000). The influence of parameter estimation on the ARL of Shewhart type charts for time series. \emph{Statistical Papers 41}(2), 173-196. W. Schmid (1995). On the run length of a Shewhart chart for correlated data. \emph{Statistical Papers 36}(1), 111-130. } \author{Sven Knoth} \seealso{ \code{xtewma.arl} for zero-state ARL computation of EWMA control charts in case of Student t distributed data. } \examples{ ## will follow } \keyword{ts} spc/man/xcusum.sf.Rd0000644000176200001440000000331513553640534014046 0ustar liggesusers\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/phat.ewma.arl.Rd0000644000176200001440000001047413553640534014560 0ustar liggesusers\name{phat.ewma.arl} \alias{phat.ewma.arl} \alias{phat.ewma.crit} \alias{phat.ewma.lambda} \title{Compute ARLs of EWMA phat control charts} \description{Computation of the (zero-state) Average Run Length (ARL), upper control limit (ucl) for given in-control ARL, and lambda for minimal out-of control ARL at given shift.} \usage{phat.ewma.arl(lambda, ucl, mu, n, z0, sigma=1, type="known", LSL=-3, USL=3, N=15, qm=25, ntype="coll") phat.ewma.crit(lambda, L0, mu, n, z0, sigma=1, type="known", LSL=-3, USL=3, N=15, qm=25) phat.ewma.lambda(L0, mu, n, z0, sigma=1, type="known", max_l=1, min_l=.001, LSL=-3, USL=3, qm=25) } \arguments{ \item{lambda}{smoothing parameter of the EWMA control chart.} \item{ucl}{upper control limit of the EWMA phat control chart.} \item{L0}{pre-defined in-control ARL (Average Run Length).} \item{mu}{true mean or mean where the ARL should be minimized (then the in-control mean is simply 0).} \item{n}{subgroup size.} \item{z0}{so-called headstart (gives fast initial response).} \item{type}{choose whether the standard deviation is given and fixed (\code{"known"}) or estimated and potentially monitored (\code{"estimated"}).} \item{sigma}{actual standard deviation of the data -- the in-control value is 1.} \item{max_l, min_l}{maximal and minimal value for optimal lambda search.} \item{LSL,USL}{lower and upper specification limit, respectively.} \item{N}{size of collocation base, dimension of the resulting linear equation system is equal to \code{N}.} \item{qm}{number of nodes for collocation quadratures.} \item{ntype}{switch between the default method \code{coll} (collocation) and the classic one \code{markov} (Markov chain approximation) for calculating the ARL numerically.} } \details{ The three implemented functions allow to apply a new type control chart. Basically, lower and upper specification limits are given. The monitoring vehicle then is the empirical probability that an item will not follow these specification given the sequence of sample means. If the related EWMA sequence violates the control limits, then the alarm indicates a significant process deterioration. For details see the paper mentioned in the references. To be able to construct the control charts, see the first example. } \value{Return single values which resemble the ARL, the critical value, and the optimal lambda, respectively.} \references{ S. Knoth and S. Steinmetz (2013), EWMA \code{p} charts under sampling by variables, \emph{International Journal of Production Research} 51, 3795-3807. } \author{Sven Knoth} \seealso{ \code{sewma.arl} for a further collocation based ARL calculation routine.} \examples{ ## Simple example to demonstrate the chart. # some functions h.mu <- function(mu) pnorm(LSL-mu) + pnorm(mu-USL) ewma <- function(x, lambda=0.1, z0=0) filter(lambda*x, 1-lambda, m="r", init=z0) # parameters LSL <- -3 # lower specification limit USL <- 3 # upper specification limit n <- 5 # batch size lambda <- 0.1 # EWMA smoothing parameter L0 <- 1000 # in-control Average Run Length (ARL) z0 <- h.mu(0) # start at minimal defect level ucl <- phat.ewma.crit(lambda, L0, 0, n, z0, LSL=LSL, USL=USL) # data x0 <- matrix(rnorm(50*n), ncol=5) # in-control data x1 <- matrix(rnorm(50*n, mean=0.5), ncol=5)# out-of-control data x <- rbind(x0,x1) # all data # create chart xbar <- apply(x, 1, mean) phat <- h.mu(xbar) z <- ewma(phat, lambda=lambda, z0=z0) plot(1:length(z), z, type="l", xlab="batch", ylim=c(0,.02)) abline(h=z0, col="grey", lwd=.7) abline(h=ucl, col="red") ## S. Knoth, S. Steinmetz (2013) # Table 1 lambdas <- c(.5, .25, .2, .1) L0 <- 370.4 n <- 5 LSL <- -3 USL <- 3 phat.ewma.CRIT <- Vectorize("phat.ewma.crit", "lambda") p.star <- pnorm( LSL ) + pnorm( -USL ) ## lower bound of the chart ucls <- phat.ewma.CRIT(lambdas, L0, 0, n, p.star, LSL=LSL, USL=USL) print(cbind(lambdas, ucls)) # Table 2 mus <- c((0:4)/4, 1.5, 2, 3) phat.ewma.ARL <- Vectorize("phat.ewma.arl", "mu") arls <- NULL for ( i in 1:length(lambdas) ) { arls <- cbind(arls, round(phat.ewma.ARL(lambdas[i], ucls[i], mus, n, p.star, LSL=LSL, USL=USL), digits=2)) } arls <- data.frame(arls, row.names=NULL) names(arls) <- lambdas print(arls) # Table 3 \dontrun{ mus <- c(.25, .5, 1, 2) phat.ewma.LAMBDA <- Vectorize("phat.ewma.lambda", "mu") lambdas <- phat.ewma.LAMBDA(L0, mus, n, p.star, LSL=LSL, USL=USL) print(cbind(mus, lambdas))} } \keyword{ts} spc/man/xgrsr.arl.Rd0000644000176200001440000001171213553640534014035 0ustar liggesusers\name{xgrsr.arl} \alias{xgrsr.arl} \title{Compute (zero-state) ARLs of Shiryaev-Roberts schemes} \description{Computation of the (zero-state) Average Run Length (ARL) for Shiryaev-Roberts schemes monitoring normal mean.} \usage{xgrsr.arl(k, g, mu, zr = 0, hs=NULL, sided = "one", q = 1, MPT = FALSE, r = 30)} \arguments{ \item{k}{reference value of the Shiryaev-Roberts scheme.} \item{g}{control limit (alarm threshold) of Shiryaev-Roberts scheme.} \item{mu}{true mean.} \item{zr}{reflection border to enable the numerical algorithms used here.} \item{hs}{so-called headstart (enables fast initial response). If \code{hs=NULL}, then the classical headstart -Inf is used (corresponds to 0 for the non-log scheme).} \item{sided}{distinguishes between one- and two-sided schemes by choosing \code{"one"} and\code{"two"}, respectively. Currently only one-sided schemes are implemented.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\ge q)}, will be determined. Note that mu0=0 is implicitely fixed.} \item{MPT}{switch between the old implementation (\code{FALSE}) and the new one (\code{TRUE}) that considers the complete likelihood ratio. MPT stands for the initials of G. Moustakides, A. Polunchenko and A. Tartakovsky.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1}.} } \details{ \code{xgrsr.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature. } \value{Returns a vector of length \code{q} which resembles the ARL and the sequence of conditional expected delays for \code{q}=1 and \code{q}>1, respectively.} \references{ S. Knoth (2006), The art of evaluating monitoring schemes -- how to measure the performance of control charts? S. Lenz, H. & Wilrich, P. (ed.), \emph{Frontiers in Statistical Quality Control 8}, Physica Verlag, Heidelberg, Germany, 74-99. G. Moustakides, A. Polunchenko, A. Tartakovsky (2009), Numerical comparison of CUSUM and Shiryaev-Roberts procedures for detecting changes in distributions, \emph{Communications in Statistics: Theory and Methods 38}, 3225-3239. } \author{Sven Knoth} \seealso{ \code{xewma.arl} and \code{xcusum-arl} for zero-state ARL computation of EWMA and CUSUM control charts, respectively, and \code{xgrsr.ad} for the steady-state ARL. } \examples{ ## Small study to identify appropriate reflection border to mimic unreflected schemes k <- .5 g <- log(390) zrs <- -(0:10) ZRxgrsr.arl <- Vectorize(xgrsr.arl, "zr") arls <- ZRxgrsr.arl(k, g, 0, zr=zrs) data.frame(zrs, arls) ## Table 2 from Knoth (2006) ## original values are # mu arl # 0 697 # 0.5 33 # 1 10.4 # 1.5 6.2 # 2 4.4 # 2.5 3.5 # 3 2.9 # k <- .5 g <- log(390) zr <- -5 # see first example mus <- (0:6)/2 Mxgrsr.arl <- Vectorize(xgrsr.arl, "mu") arls <- round(Mxgrsr.arl(k, g, mus, zr=zr), digits=1) data.frame(mus, arls) XGRSR.arl <- Vectorize("xgrsr.arl", "g") zr <- -6 ## Table 2 from Moustakides et al. (2009) ## original values are # gamma A ARL/E_infty(L) SADD/E_1(L) # 50 47.17 50.29 41.40 # 100 94.34 100.28 72.32 # 500 471.70 500.28 209.44 # 1000 943.41 1000.28 298.50 # 5000 4717.04 5000.24 557.87 #10000 9434.08 10000.17 684.17 theta <- .1 As2 <- c(47.17, 94.34, 471.7, 943.41, 4717.04, 9434.08) gs2 <- log(As2) arls0 <- round(XGRSR.arl(theta/2, gs2, 0, zr=-5, r=300, MPT=TRUE), digits=2) arls1 <- round(XGRSR.arl(theta/2, gs2, theta, zr=-5, r=300, MPT=TRUE), digits=2) data.frame(As2, arls0, arls1) ## Table 3 from Moustakides et al. (2009) ## original values are # gamma A ARL/E_infty(L) SADD/E_1(L) # 50 37.38 49.45 12.30 # 100 74.76 99.45 16.60 # 500 373.81 499.45 28.05 # 1000 747.62 999.45 33.33 # 5000 3738.08 4999.45 45.96 #10000 7476.15 9999.24 51.49 theta <- .5 As3 <- c(37.38, 74.76, 373.81, 747.62, 3738.08, 7476.15) gs3 <- log(As3) arls0 <- round(XGRSR.arl(theta/2, gs3, 0, zr=-5, r=70, MPT=TRUE), digits=2) arls1 <- round(XGRSR.arl(theta/2, gs3, theta, zr=-5, r=70, MPT=TRUE), digits=2) data.frame(As3, arls0, arls1) ## Table 4 from Moustakides et al. (2009) ## original values are # gamma A ARL/E_infty(L) SADD/E_1(L) # 50 28.02 49.78 4.98 # 100 56.04 99.79 6.22 # 500 280.19 499.79 9.30 # 1000 560.37 999.79 10.66 # 5000 2801.85 5000.93 13.86 #10000 5603.70 9999.87 15.24 theta <- 1 As4 <- c(28.02, 56.04, 280.19, 560.37, 2801.85, 5603.7) gs4 <- log(As4) arls0 <- round(XGRSR.arl(theta/2, gs4, 0, zr=-6, r=40, MPT=TRUE), digits=2) arls1 <- round(XGRSR.arl(theta/2, gs4, theta, zr=-6, r=40, MPT=TRUE), digits=2) data.frame(As4, arls0, arls1) } \keyword{ts} spc/man/tewma.arl.Rd0000644000176200001440000000373613553640534014014 0ustar liggesusers\name{tewma.arl} \alias{tewma.arl} \title{Compute ARLs of Poisson TEWMA control charts} \description{Computation of the (zero-state) Average Run Length (ARL) at given Poisson mean \code{mu}.} \usage{tewma.arl(lambda, k, lk, uk, mu, z0, rando=FALSE, gl=0, gu=0)} \arguments{ \item{lambda}{smoothing parameter of the EWMA p control chart.} \item{k}{resolution of grid (natural number).} \item{lk}{lower control limit of the TEWMA control chart, integer.} \item{uk}{upper control limit of the TEWMA control chart, integer.} \item{mu}{mean value of Poisson distribution.} \item{z0}{so-called headstart (give fast initial response) -- it is proposed to use the in-control mean.} \item{rando}{Distinguish between control chart design without or with randomisation. In the latter case some meaningful values for \code{gl} and \code{gu} should be provided.} \item{gl}{randomisation probability at the lower limit.} \item{gu}{randomisation probability at the upper limit.} } \details{ A new idea of applying EWMA smoothing to count data. Here, the thinning operation is applied to independent Poisson variates is performed. Moreover, the original thinning principle is expanded to multiples of one over \code{k} to allow finer grids and finally better detection perfomance. It is highly recommended to read the corresponding paper (see below). } \value{Return single value which resemble the ARL.} \references{ M. C. Morais, C. H. Weiss, S. Knoth (2019), A thinning-based EWMA chart to monitor counts, submitted. } \author{Sven Knoth} \seealso{later.} \examples{ # MWK (2018) lambda <- 0.1 # (T)EWMA smoothing constant mu0 <- 5 # in-control mean k <- 10 # resolution z0 <- round(k*mu0) # starting value of (T)EWMA sequence # (i) without randomisation lk <- 28 uk <- 75 L0 <- tewma.arl(lambda, k, lk, uk, mu0, z0) # should be 501.9703 # (ii) with randomisation uk <- 76 # lk is not changed gl <- 0.5446310 gu <- 0.1375617 L0 <- tewma.arl(lambda, k, lk, uk, mu0, z0, rando=TRUE, gl=gl, gu=gu) # should be 500 } \keyword{ts} spc/man/xDcusum.arl.Rd0000644000176200001440000001144013553640534014316 0ustar liggesusers\name{xDcusum.arl} \alias{xDcusum.arl} \title{Compute ARLs of CUSUM control charts under drift} \description{Computation of the (zero-state and other) Average Run Length (ARL) under drift for one-sided CUSUM control charts monitoring normal mean.} \usage{xDcusum.arl(k, h, delta, hs = 0, sided = "one", mode = "Gan", m = NULL, q = 1, r = 30, with0 = FALSE)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.} \item{delta}{true drift parameter.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided CUSUM control chart by choosing \code{"one"} and \code{"two"}, respectively. Currentlly, the two-sided scheme is not implemented.} \item{mode}{decide whether Gan's or Knoth's approach is used. Use \code{"Gan"} and \code{"Knoth"}, respectively.} \item{m}{parameter used if \code{mode="Gan"}. \code{m} is design parameter of Gan's approach. If \code{m=NULL}, then \code{m} will increased until the resulting ARL does not change anymore.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\geq)}, will be determined. Note that mu0=0 is implicitely fixed. Deploy large \code{q} to mimic steady-state. It works only for \code{mode="Knoth"}.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} \item{with0}{defines whether the first observation used for the RL calculation follows already 1*delta or still 0*delta. With \code{q} additional flexibility is given.} } \details{ Based on Gan (1991) or Knoth (2003), the ARL is calculated for one-sided CUSUM control charts under drift. In case of Gan's framework, the usual ARL function with mu=m*delta is determined and recursively via m-1, m-2, ... 1 (or 0) the drift ARL determined. The framework of Knoth allows to calculate ARLs for varying parameters, such as control limits and distributional parameters. For details see the cited papers. Note that two-sided CUSUM charts under drift are difficult to treat. } \value{Returns a single value which resembles the ARL.} \references{ F. F. Gan (1992), CUSUM control charts under linear drift, \emph{Statistician 41}, 71-84. F. F. Gan (1996), Average Run Lengths for Cumulative Sum control chart under linear trend, \emph{Applied Statistics 45}, 505-512. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2012), More on Control Charting under Drift, in: \emph{Frontiers in Statistical Quality Control 10}, H.-J. Lenz, W. Schmid and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 53-68. C. Zou, Y. Liu and Z. Wang (2009), Comparisons of control schemes for monitoring the means of processes subject to drifts, \emph{Metrika 70}, 141-163. } \author{Sven Knoth} \seealso{ \code{xcusum.arl} and \code{xcusum.ad} for zero-state and steady-state ARL computation of CUSUM control charts for the classical step change model. } \examples{ ## Gan (1992) ## Table 1 ## original values are # deltas arl # 0.0001 475 # 0.0005 261 # 0.0010 187 # 0.0020 129 # 0.0050 76.3 # 0.0100 52.0 # 0.0200 35.2 # 0.0500 21.4 # 0.1000 15.0 # 0.5000 6.95 # 1.0000 5.16 # 3.0000 3.30 \dontrun{k <- .25 h <- 8 r <- 50 DxDcusum.arl <- Vectorize(xDcusum.arl, "delta") deltas <- c(0.0001, 0.0005, 0.001, 0.002, 0.005, 0.01, 0.02, 0.05, 0.1, 0.5, 1, 3) arl.like.Gan <- round(DxDcusum.arl(k, h, deltas, r=r, with0=TRUE), digits=2) arl.like.Knoth <- round(DxDcusum.arl(k, h, deltas, r=r, mode="Knoth", with0=TRUE), digits=2) data.frame(deltas, arl.like.Gan, arl.like.Knoth)} ## Zou et al. (2009) ## Table 1 ## original values are # delta arl1 arl2 arl3 # 0 ~ 1730 # 0.0005 345 412 470 # 0.001 231 275 317 # 0.005 86.6 98.6 112 # 0.01 56.9 61.8 69.3 # 0.05 22.6 21.6 22.7 # 0.1 15.4 14.7 14.2 # 0.5 6.60 5.54 5.17 # 1.0 4.63 3.80 3.45 # 2.0 3.17 2.67 2.32 # 3.0 2.79 2.04 1.96 # 4.0 2.10 1.98 1.74 \dontrun{ k1 <- 0.25 k2 <- 0.5 k3 <- 0.75 h1 <- 9.660 h2 <- 5.620 h3 <- 3.904 deltas <- c(0.0005, 0.001, 0.005, 0.01, 0.05, 0.1, 0.5, 1:4) arl1 <- c(round(xcusum.arl(k1, h1, 0, r=r), digits=2), round(DxDcusum.arl(k1, h1, deltas, r=r), digits=2)) arl2 <- c(round(xcusum.arl(k2, h2, 0), digits=2), round(DxDcusum.arl(k2, h2, deltas, r=r), digits=2)) arl3 <- c(round(xcusum.arl(k3, h3, 0, r=r), digits=2), round(DxDcusum.arl(k3, h3, deltas, r=r), digits=2)) data.frame(delta=c(0, deltas), arl1, arl2, arl3)} } \keyword{ts} spc/man/xewma.crit.Rd0000644000176200001440000000366113553640534014200 0ustar liggesusers\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/sewma.sf.Rd0000644000176200001440000000444413553640534013642 0ustar liggesusers\name{sewma.sf} \alias{sewma.sf} \title{Compute the survival function of EWMA run length} \description{Computation of the survival function of the Run Length (RL) for EWMA control charts monitoring normal variance.} \usage{sewma.sf(n, l, cl, cu, sigma, df, hs=1, sided="upper", r=40, qm=30)} \arguments{ \item{n}{calculate sf up to value \code{n}.} \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{cl}{lower control limit of the EWMA control chart.} \item{cu}{upper control limit of the EWMA control chart.} \item{sigma}{true standard deviation.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{r}{dimension of the resulting linear equation system (highest order of the collocation polynomials).} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} } \details{ The survival function P(L>n) and derived from it also the cdf P(L<=n) and the pmf P(L=n) illustrate the distribution of the EWMA run length. For large n the geometric tail could be exploited. That is, with reasonable large n the complete distribution is characterized. The algorithm is based on Waldmann's survival function iteration procedure and on results in Knoth (2007). } \value{Returns a vector which resembles the survival function up to a certain point.} \references{ S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{sewma.arl} for zero-state ARL computation of variance EWMA control charts. } \examples{ ## will follow } \keyword{ts} spc/man/pois.ewma.arl.Rd0000644000176200001440000000627513660532007014574 0ustar liggesusers\name{pois.ewma.arl} \alias{pois.ewma.arl} \title{Compute ARLs of Poisson EWMA control charts} \description{Computation of the (zero-state) Average Run Length (ARL) at given mean \code{mu}.} \usage{pois.ewma.arl(lambda, AL, AU, mu0, z0, mu, sided="two", rando=FALSE, gL=0, gU=0, mcdesign="transfer", N=101)} \arguments{ \item{lambda}{smoothing parameter of the EWMA p control chart.} \item{AL, AU}{factors to build the lower and upper control limit, respectively, of the Poisson EWMA control chart.} \item{mu0}{in-control mean.} \item{z0}{so-called headstart (give fast initial response).} \item{mu}{actual mean.} \item{sided}{distinguishes between one- and two-sided EWMA control chart by choosing \code{"upper"}, \code{"lower"}, and \code{"two"}, and \code{"zwei"}, respectively.} \item{rando}{Switch between the standard limit treatment, \code{FALSE}, and an additional randomisation (to allow `perfect' ARL calibration) by setting \code{TRUE}. If randomisation is used, then set the corresponding probailities, \code{gL} and \code{gU}, appropriately.} \item{gL, gU}{If the EWMA statistic is at the limit (approximately), then an alarm is triggered with probability \code{gL} and \code{gU} for the lower and upper limit, respectively.} \item{mcdesign}{choose either \code{"classic"} which follows Borror, Champ and Rigdon (1998), or the more sophisticated \code{"transfer"} which improves the accuracy heavily.} \item{N}{number of states of the approximating Markov chain; is equal to the dimension of the resulting linear equation system.} } \details{ The monitored data follow a Poisson distribution with \code{mu}. The ARL values of the resulting EWMA control chart are determined by Markov chain approximation. We follow the algorithm given in Borror, Champ and Rigdon (1998). However, by setting \code{mcdesign="transfer"} (now the default) from Morais and Knoth (2020), the accuracy is considerably improved. } \value{Return single value which resembles the ARL.} \references{ C. M. Borror, C. W. Champ and S. E. Rigdon (1998) Poisson EWMA control charts, \emph{Journal of Quality Technonlogy} 30(4), 352-361. M. C. Morais and S. Knoth (2020) Improving the ARL profile and the accuracy of its calculation for Poisson EWMA charts, \emph{Quality and Reliability Engineering International} 36(3), 876-889. } \author{Sven Knoth} \seealso{later.} \examples{ ## Borror, Champ and Rigdon (1998), Table 2, PEWMA column mu0 <- 20 lambda <- 0.27 A <- 3.319 mu1 <- c(2*(3:15), 35) ARL1 <- rep(NA, length(mu1)) for ( i in 1:length(mu1) ) ARL1[i] <- pois.ewma.arl(lambda, A, A, mu0, mu0, mu1[i], mcdesign="classic") print(cbind(mu1, round(ARL1, digits=1))) ## the same numbers with improved accuracy ARL2 <- rep(NA, length(mu1)) for ( i in 1:length(mu1) ) ARL2[i] <- pois.ewma.arl(lambda, A, A, mu0, mu0, mu1[i], mcdesign="transfer") print(cbind(mu1, round(ARL2, digits=1))) ## Morais and Knoth (2020), Table 2, lambda = 0.27 column lambda <- 0.27 AL <- 3.0870 AU <- 3.4870 gL <- 0.001029 gU <- 0.000765 mu0 <- 20 mu1 <- c(16, 18, 19.99, mu0, 20.01, 22, 24) ARL3 <- rep(NA, length(mu1)) for ( i in 1:length(mu1) ) ARL3[i] <- pois.ewma.arl(lambda,AL,AU,mu0,mu0,mu1[i],rando=TRUE,gL=gL,gU=gU, N=101) print(cbind(mu1, round(ARL3, digits=1))) } \keyword{ts} spc/man/sewma.crit.prerun.Rd0000644000176200001440000000762713553640534015513 0ustar liggesusers\name{sewma.crit.prerun} \alias{sewma.crit.prerun} \title{Compute critical values of of EWMA (variance charts) control charts under pre-run uncertainty} \description{Computation of quantiles of the Run Length (RL) for EWMA control charts monitoring normal variance.} \usage{sewma.crit.prerun(l,L0,df1,df2,sigma0=1,cl=NULL,cu=NULL,hs=1,sided="upper", mode="fixed",r=40,qm=30,qm.sigma=30,truncate=1e-10, tail_approx=TRUE,c.error=1e-10,a.error=1e-9)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{L0}{in-control quantile value.} \item{df1}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{df2}{degrees of freedom of the pre-run variance estimator.} \item{sigma,sigma0}{true and in-control standard deviation, respectively.} \item{cl}{deployed for \code{sided}=\code{"Rupper"}, that is, upper variance control chart with lower reflecting barrier \code{cl}.} \item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit (\code{mode}=\code{"fixed"}) a value larger than \code{sigma0} has to been given, for all other cases \code{cu} is ignored.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}),and \code{"two"} (two-sided chart), respectively.} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit (see \code{cu}) is set and only the lower is calculated to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated).} \item{r}{dimension of the resulting linear equation system (highest order of the collocation polynomials).} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} \item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.} \item{truncate}{size of truncated tail.} \item{tail_approx}{controls whether the geometric tail approximation is used (is faster) or not.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{a.error}{error bound for the quantile level \code{alpha} during applying the secant rule.} } \details{ \code{sewma.crit.prerun} determines the critical values (similar to alarm limits) for given in-control ARL \code{L0} by applying secant rule and using \code{sewma.arl.prerun()}. In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"} a two-dimensional secant rule is applied that also ensures that the maximum of the ARL function for given standard deviation is attained at \code{sigma0}. See Knoth (2010) for some details of the algorithm involved. } \value{Returns the lower and upper control limit \code{cl} and \code{cu}.} \references{ H.-J. Mittag and D. Stemann and B. Tewes (1998), EWMA-Karten zur \"Uberwachung der Streuung von Qualit\"atsmerkmalen, \emph{Allgemeines Statistisches Archiv 82}, 327-338, S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2010), Control Charting Normal Variance -- Reflections, Curiosities, and Recommendations, in \emph{Frontiers in Statistical Quality Control 9}, H.-J. Lenz and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 3-18. } \author{Sven Knoth} \seealso{\code{sewma.arl.prerun} for calculation of ARL of variance charts under pre-run uncertainty and \code{sewma.crit} for the algorithm w/o pre-run uncertainty.} \examples{ ## will follow } \keyword{ts} spc/man/xtewma.ad.Rd0000644000176200001440000000473113553640534014006 0ustar liggesusers\name{xtewma.ad} \alias{xtewma.ad} \title{Compute steady-state ARLs of EWMA control charts, t distributed data} \description{Computation of the steady-state Average Run Length (ARL) for different types of EWMA control charts monitoring the mean of t distributed data.} \usage{xtewma.ad(l, c, df, mu1, mu0=0, zr=0, z0=0, sided="one", limits="fix", steady.state.mode="conditional", mode="tan", r=40)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{df}{degrees of freedom -- parameter of the t distribution.} \item{mu1}{in-control mean.} \item{mu0}{out-of-control mean.} \item{zr}{reflection border for the one-sided chart.} \item{z0}{restarting value of the EWMA sequence in case of a false alarm in \code{steady.state.mode="cyclical"}.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different control limits behavior.} \item{steady.state.mode}{distinguishes between two steady-state modes -- conditional and cyclical.} \item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently, \code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} } \details{ \code{xtewma.ad} determines the steady-state Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature and using the power method for deriving the largest in magnitude eigenvalue and the related left eigenfunction. } \value{Returns a single value which resembles the steady-state ARL.} \references{ R. B. Crosier (1986), A new two-sided cumulative quality control scheme, \emph{Technometrics 28}, 187-194. S. V. Crowder (1987), A simple method for studying run-length distributions of exponentially weighted moving average charts, \emph{Technometrics 29}, 401-407. J. M. Lucas and M. S. Saccucci (1990), Exponentially weighted moving average control schemes: Properties and enhancements, \emph{Technometrics 32}, 1-12. } \author{Sven Knoth} \seealso{ \code{xtewma.arl} for zero-state ARL computation and \code{xewma.ad} for the steady-state ARL for normal data.} \examples{ ## will follow } \keyword{ts} spc/man/pois.cusum.arl.Rd0000644000176200001440000000671213555253726015006 0ustar liggesusers\name{pois.cusum.arl} \alias{pois.cusum.arl} \title{Compute ARLs of Poisson CUSUM control charts} \description{Computation of the (zero-state) Average Run Length (ARL) at given mean \code{mu}.} \usage{pois.cusum.arl(mu, km, hm, m, i0=0, sided="upper", rando=FALSE, gamma=0, km2=0, hm2=0, m2=0, i02=0, gamma2=0)} \arguments{ \item{mu}{actual mean.} \item{km}{enumerator of rational approximation of reference value \code{k}.} \item{hm}{enumerator of rational approximation of reference value \code{h}.} \item{m}{denominator of rational approximation of reference value.} \item{i0}{head start value as integer multiple of \code{1/m}; should be an element of \code{0:hm}.} \item{sided}{distinguishes between different one- and two-sided CUSUM control chart by choosing \code{"upper"}, \code{"lower"} and \code{"two"}, respectively.} \item{rando}{Switch for activating randomization in order to allow continuous ARL control.} \item{gamma}{Randomization probability. If the CUSUM statistic is equal to the threshold \code{h}, an control chart alarm is triggered with probability \code{gamma}.} \item{km2,hm2,m2,i02,gamma2}{corresponding values of the second CUSUM chart (to building a two-sided CUSUM scheme).} } \details{ The monitored data follow a Poisson distribution with \code{mu}. The ARL values of the resulting EWMA control chart are determined via Markov chain calculations. We follow the algorithm given in Lucas (1985) expanded with some arithmetic 'tricks' (e.g., by deploying Toeplitz matrix algebra). A paper explaining it is under preparation. } \value{Returns a single value which resembles the ARL.} \references{ J. M. Lucas (1985) Counted data CUSUM's, \emph{Technometrics} 27(2), 129-144. C. H. White and J. B. Keats (1996) ARLs and Higher-Order Run-Length Moments for the Poisson CUSUM, \emph{Journal of Quality Technology} 28(3), 363-369. C. H. White, J. B. Keats and J. Stanley (1997) Poisson CUSUM versus c chart for defect data, \emph{Quality Engineering} 9(4), 673-679. G. Rossi and L. Lampugnani and M. Marchi (1999), An approximate CUSUM procedure for surveillance of health events, \emph{Statistics in Medicine} 18(16), 2111-2122. S. W. Han, K.-L. Tsui, B. Ariyajunya, and S. B. Kim (2010), A comparison of CUSUM, EWMA, and temporal scan statistics for detection of increases in poisson rates, \emph{Quality and Reliability Engineering International} 26(3), 279-289. M. B. Perry and J. J. Pignatiello Jr. (2011) Estimating the time of step change with Poisson CUSUM and EWMA control charts, \emph{International Journal of Production Research} 49(10), 2857-2871. } \author{Sven Knoth} \seealso{later.} \examples{ ## Lucas 1985, upper chart (Tables 2 and 3) k <- .25 h <- 10 m <- 4 km <- m * k hm <- m * h mu0 <- 1 * k ARL <- pois.cusum.arl(mu0, km, hm-1, m) # Lucas reported 438 (in Table 2, first block, row 10.0 .25 .0 ..., column 1.0 # Recall that Lucas and other trigger an alarm, if the CUSUM statistic is greater than # or equal to the alarm threshold h print(ARL) ARL <- pois.cusum.arl(mu0, km, hm-1, m, i0=round((hm-1)/2)) # Lucas reported 333 (in Table 3, first block, row 10.0 .25 .0 ..., column 1.0 print(ARL) ## Lucas 1985, lower chart (Tables 4 and 5) ARL <- pois.cusum.arl(mu0, km, hm-1, m, sided="lower") # Lucas reported 437 (in Table 4, first block, row 10.0 .25 .0 ..., column 1.0 print(ARL) ARL <- pois.cusum.arl(mu0, km, hm-1, m, i0=round((hm-1)/2), sided="lower") # Lucas reported 318 (in Table 5, first block, row 10.0 .25 .0 ..., column 1.0 print(ARL) } \keyword{ts} spc/man/xewma.sf.Rd0000644000176200001440000000607713553640534013653 0ustar liggesusers\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/xcusum.crit.Rd0000644000176200001440000000263413553640534014402 0ustar liggesusers\name{xcusum.crit} \alias{xcusum.crit} \title{Compute decision intervals of CUSUM control charts} \description{Computation of the decision intervals (alarm limits) for different types of CUSUM control charts monitoring normal mean.} \usage{xcusum.crit(k, L0, mu0 = 0, hs = 0, sided = "one", r = 30)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{L0}{in-control ARL.} \item{mu0}{in-control mean.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one-, two-sided and Crosier's modified two-sided CUSUM scheme by choosing \code{"one"}, \code{"two"}, and \code{"Crosier"}, respectively.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-, two-sided) or \code{2r+1} (Crosier).} } \details{ \code{xcusum.crit} determines the decision interval (alarm limit) for given in-control ARL \code{L0} by applying secant rule and using \code{xcusum.arl()}. } \value{Returns a single value which resembles the decision interval \code{h}.} %\references{Later...} \author{Sven Knoth} \seealso{\code{xcusum.arl} for zero-state ARL computation.} \examples{ k <- .5 incontrolARL <- c(500,5000,50000) sapply(incontrolARL,k=k,xcusum.crit,r=10) # accuracy with 10 nodes sapply(incontrolARL,k=k,xcusum.crit,r=20) # accuracy with 20 nodes sapply(incontrolARL,k=k,xcusum.crit) # accuracy with 30 nodes } \keyword{ts} spc/man/mewma.psi.Rd0000644000176200001440000000344313553640534014015 0ustar liggesusers\name{mewma.psi} \alias{mewma.psi} \title{Compute steady-state density of the MEWMA statistic} \description{Computation of the (zero-state) steady-state density function of the statistic deployed in multivariate exponentially weighted moving average (MEWMA) charts monitoring multivariate normal mean.} \usage{mewma.psi(l, cE, p, type="cond", hs=0, r=20)} \arguments{ \item{l}{smoothing parameter lambda of the MEWMA control chart.} \item{cE}{alarm threshold of the MEWMA control chart.} \item{p}{dimension of multivariate normal distribution.} \item{type}{switch between \code{"cond"} and \code{"cycl"} for differentiating between the conditional (no false alarm) and the cyclical (after false alarm re-start in \code{hs}), respectively.} \item{hs}{the re-starting point for the cyclical steady-state framework.} \item{r}{number of quadrature nodes.} } \details{Basically, ideas from Knoth (2017, MEWMA numerics) and Knoth (2016, steady-state ARL concepts) are merged. More details will follow.} \value{Returns a function.} \references{ Sven Knoth (2016), The Case Against the Use of Synthetic Control Charts, \emph{Journal of Quality Technology 48(2)}, 178-195. Sven Knoth (2017), ARL Numerics for MEWMA Charts, \emph{Journal of Quality Technology 49(1)}, 78-89. Sven Knoth (2018), The Steady-State Behavior of Multivariate Exponentially Weighted Moving Average Control Charts, \emph{Sequential Analysis 37(4)}, 511-529. } \author{Sven Knoth} \seealso{ \code{mewma.arl} for calculating the in-control ARL of MEWMA. } \examples{ lambda <- 0.1 L0 <- 200 p <- 3 h4 <- mewma.crit(lambda, L0, p) x_ <- seq(0, h4*lambda/(2-lambda), by=0.002) psi <- mewma.psi(lambda, h4, p) psi_ <- psi(x_) # plot(x_, psi_, type="l", xlab="x", ylab=expression(psi(x)), xlim=c(0,1.2)) # cf. to Figure 1 in Knoth (2018), p. 514, p=3 } \keyword{ts} spc/man/xewma.arl.Rd0000644000176200001440000002517713553640534014023 0ustar liggesusers\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, steady.state.mode="conditional",r=40)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{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{steady.state.mode}{distinguishes between two steady-state modes -- conditional and cyclical (needed for \code{q>1}).} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} } \details{ In case of the EWMA chart with fixed control limits, \code{xewma.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature. If \code{limits} is not \code{"fix"}, then the method presented in Knoth (2003) is utilized. Note that for one-sided EWMA charts (\code{sided}=\code{"one"}), only \code{"vacl"} and \code{"stat"} are deployed, while for two-sided ones (\code{sided}=\code{"two"}) also \code{"fir"}, \code{"both"} (combination of \code{"fir"} and \code{"vacl"}), and \code{"Steiner"} are implemented. For details see Knoth (2004). } \value{Except for the fixed limits EWMA charts it returns a single value which resembles the ARL. For fixed limits charts, it returns a vector of length \code{q} which resembles the ARL and the sequence of conditional expected delays for \code{q}=1 and \code{q}>1, respectively.} \references{ K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. S. V. Crowder (1987), A simple method for studying run-length distributions of exponentially weighted moving average charts, \emph{Technometrics 29}, 401-407. J. M. Lucas and M. S. Saccucci (1990), Exponentially weighted moving average control schemes: Properties and enhancements, \emph{Technometrics 32}, 1-12. S. Chandrasekaran, J. R. English and R. L. Disney (1995), Modeling and analysis of EWMA control schemes with variance-adjusted control limits, \emph{IIE Transactions 277}, 282-290. T. R. Rhoads, D. C. Montgomery and C. M. Mastrangelo (1996), Fast initial response scheme for exponentially weighted moving average control chart, \emph{Quality Engineering 9}, 317-327. S. H. Steiner (1999), EWMA control charts with time-varying control limits and fast initial response, \emph{Journal of Quality Technology 31}, 75-86. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. } \author{Sven Knoth} \seealso{ \code{xcusum.arl} for zero-state ARL computation of CUSUM control charts and \code{xewma.ad} for the steady-state ARL. } \examples{ ## Waldmann (1986), one-sided EWMA l <- .75 round(xewma.arl(l,2*sqrt((2-l)/l),0,zr=-4*sqrt((2-l)/l)),digits=1) l <- .5 round(xewma.arl(l,2*sqrt((2-l)/l),0,zr=-4*sqrt((2-l)/l)),digits=1) ## original values are 209.3 and 3907.5 (in Table 2). ## Waldmann (1986), two-sided EWMA with fixed control limits l <- .75 round(xewma.arl(l,2*sqrt((2-l)/l),0,sided="two"),digits=1) l <- .5 round(xewma.arl(l,2*sqrt((2-l)/l),0,sided="two"),digits=1) ## original values are 104.0 and 1952 (in Table 1). ## Crowder (1987), two-sided EWMA with fixed control limits l1 <- .5 l2 <- .05 c <- 2 mu <- (0:16)/4 arl1 <- sapply(mu,l=l1,c=c,sided="two",xewma.arl) arl2 <- sapply(mu,l=l2,c=c,sided="two",xewma.arl) round(cbind(mu,arl1,arl2),digits=2) ## original results are (in Table 1) ## 0.00 26.45 127.53 ## 0.25 20.12 43.94 ## 0.50 11.89 18.97 ## 0.75 7.29 11.64 ## 1.00 4.91 8.38 ## 1.25 3.95* 6.56 ## 1.50 2.80 5.41 ## 1.75 2.29 4.62 ## 2.00 1.94 4.04 ## 2.25 1.70 3.61 ## 2.50 1.51 3.26 ## 2.75 1.37 2.99 ## 3.00 1.26 2.76 ## 3.25 1.18 2.56 ## 3.50 1.12 2.39 ## 3.75 1.08 2.26 ## 4.00 1.05 2.15 (* -- in Crowder (1987) typo!?) ## Lucas/Saccucci (1990) ## two-sided EWMA ## with fixed limits l1 <- .5 l2 <- .03 c1 <- 3.071 c2 <- 2.437 mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,3.5,4,5) arl1 <- sapply(mu,l=l1,c=c1,sided="two",xewma.arl) arl2 <- sapply(mu,l=l2,c=c2,sided="two",xewma.arl) round(cbind(mu,arl1,arl2),digits=2) ## original results are (in Table 3) ## 0.00 500. 500. ## 0.25 255. 76.7 ## 0.50 88.8 29.3 ## 0.75 35.9 17.6 ## 1.00 17.5 12.6 ## 1.50 6.53 8.07 ## 2.00 3.63 5.99 ## 2.50 2.50 4.80 ## 3.00 1.93 4.03 ## 3.50 1.58 3.49 ## 4.00 1.34 3.11 ## 5.00 1.07 2.55 \dontrun{ ## with fir feature l1 <- .5 l2 <- .03 c1 <- 3.071 c2 <- 2.437 hs1 <- c1/2 hs2 <- c2/2 mu <- c(0,.5,1,2,3,5) arl1 <- sapply(mu,l=l1,c=c1,hs=hs1,sided="two",limits="fir",xewma.arl) arl2 <- sapply(mu,l=l2,c=c2,hs=hs2,sided="two",limits="fir",xewma.arl) round(cbind(mu,arl1,arl2),digits=2) ## original results are (in Table 5) ## 0.0 487. 406. ## 0.5 86.1 18.4 ## 1.0 15.9 7.36 ## 2.0 2.87 3.43 ## 3.0 1.45 2.34 ## 5.0 1.01 1.57 ## Chandrasekaran, English, Disney (1995) ## two-sided EWMA with fixed and variance adjusted limits (vacl) l1 <- .25 l2 <- .1 c1s <- 2.9985 c1n <- 3.0042 c2s <- 2.8159 c2n <- 2.8452 mu <- c(0,.25,.5,.75,1,2) arl1s <- sapply(mu,l=l1,c=c1s,sided="two",xewma.arl) arl1n <- sapply(mu,l=l1,c=c1n,sided="two",limits="vacl",xewma.arl) arl2s <- sapply(mu,l=l2,c=c2s,sided="two",xewma.arl) arl2n <- sapply(mu,l=l2,c=c2n,sided="two",limits="vacl",xewma.arl) round(cbind(mu,arl1s,arl1n,arl2s,arl2n),digits=2) ## original results are (in Table 2) ## 0.00 500. 500. 500. 500. ## 0.25 170.09 167.54 105.90 96.6 ## 0.50 48.14 45.65 31.08 24.35 ## 0.75 20.02 19.72 15.71 10.74 ## 1.00 11.07 9.37 10.23 6.35 ## 2.00 3.59 2.64 4.32 2.73 ## The results in Chandrasekaran, English, Disney (1995) are not ## that accurate. Let us consider the more appropriate comparison c1s <- xewma.crit(l1,500,sided="two") c1n <- xewma.crit(l1,500,sided="two",limits="vacl") c2s <- xewma.crit(l2,500,sided="two") c2n <- xewma.crit(l2,500,sided="two",limits="vacl") mu <- c(0,.25,.5,.75,1,2) arl1s <- sapply(mu,l=l1,c=c1s,sided="two",xewma.arl) arl1n <- sapply(mu,l=l1,c=c1n,sided="two",limits="vacl",xewma.arl) arl2s <- sapply(mu,l=l2,c=c2s,sided="two",xewma.arl) arl2n <- sapply(mu,l=l2,c=c2n,sided="two",limits="vacl",xewma.arl) round(cbind(mu,arl1s,arl1n,arl2s,arl2n),digits=2) ## which demonstrate the abilities of the variance-adjusted limits ## scheme more explicitely. ## Rhoads, Montgomery, Mastrangelo (1996) ## two-sided EWMA with fixed and variance adjusted limits (vacl), ## with fir and both features l <- .03 c <- 2.437 mu <- c(0,.5,1,1.5,2,3,4) sl <- sqrt(l*(2-l)) arlfix <- sapply(mu,l=l,c=c,sided="two",xewma.arl) arlvacl <- sapply(mu,l=l,c=c,sided="two",limits="vacl",xewma.arl) arlfir <- sapply(mu,l=l,c=c,hs=c/2,sided="two",limits="fir",xewma.arl) arlboth <- sapply(mu,l=l,c=c,hs=c/2*sl,sided="two",limits="both",xewma.arl) round(cbind(mu,arlfix,arlvacl,arlfir,arlboth),digits=1) ## original results are (in Table 1) ## 0.0 477.3* 427.9* 383.4* 286.2* ## 0.5 29.7 20.0 18.6 12.8 ## 1.0 12.5 6.5 7.4 3.6 ## 1.5 8.1 3.3 4.6 1.9 ## 2.0 6.0 2.2 3.4 1.4 ## 3.0 4.0 1.3 2.4 1.0 ## 4.0 3.1 1.1 1.9 1.0 ## * -- the in-control values differ sustainably from the true values! ## Steiner (1999) ## two-sided EWMA control charts with various modifications ## fixed vs. variance adjusted limits l <- .05 c <- 3 mu <- c(0,.25,.5,.75,1,1.5,2,2.5,3,3.5,4) arlfix <- sapply(mu,l=l,c=c,sided="two",xewma.arl) arlvacl <- sapply(mu,l=l,c=c,sided="two",limits="vacl",xewma.arl) round(cbind(mu,arlfix,arlvacl),digits=1) ## original results are (in Table 2) ## 0.00 1379.0 1353.0 ## 0.25 135.0 127.0 ## 0.50 37.4 32.5 ## 0.75 20.0 15.6 ## 1.00 13.5 9.0 ## 1.50 8.3 4.5 ## 2.00 6.0 2.8 ## 2.50 4.8 2.0 ## 3.00 4.0 1.6 ## 3.50 3.4 1.3 ## 4.00 3.0 1.1 ## fir, both, and Steiner's modification l <- .03 cfir <- 2.44 cboth <- 2.54 cstein <- 2.55 hsfir <- cfir/2 hsboth <- cboth/2*sqrt(l*(2-l)) mu <- c(0,.5,1,1.5,2,3,4) arlfir <- sapply(mu,l=l,c=cfir,hs=hsfir,sided="two",limits="fir",xewma.arl) arlboth <- sapply(mu,l=l,c=cboth,hs=hsboth,sided="two",limits="both",xewma.arl) arlstein <- sapply(mu,l=l,c=cstein,sided="two",limits="Steiner",xewma.arl) round(cbind(mu,arlfir,arlboth,arlstein),digits=1) ## original values are (in Table 5) ## 0.0 383.0 384.0 391.0 ## 0.5 18.6 14.9 13.8 ## 1.0 7.4 3.9 3.6 ## 1.5 4.6 2.0 1.8 ## 2.0 3.4 1.4 1.3 ## 3.0 2.4 1.1 1.0 ## 4.0 1.9 1.0 1.0 ## SAS/QC manual 1999 ## two-sided EWMA control charts with fixed limits l <- .25 c <- 3 mu <- 1 print(xewma.arl(l,c,mu,sided="two"),digits=11) # original value is 11.154267016. ## Some recent examples for one-sided EWMA charts ## with varying limits and in the so-called stationary mode # 1. varying limits = "vacl" lambda <- .1 L0 <- 500 ## Monte Carlo results (10^9 replicates) # mu ARL s.e. # 0 500.00 0.0160 # 0.5 21.637 0.0006 # 1 6.7596 0.0001 # 1.5 3.5398 0.0001 # 2 2.3038 0.0000 # 2.5 1.7004 0.0000 # 3 1.3675 0.0000 zr <- -6 r <- 50 c <- xewma.crit(lambda, L0, zr=zr, limits="vacl", r=r) Mxewma.arl <- Vectorize(xewma.arl, "mu") mus <- (0:6)/2 arls <- round(Mxewma.arl(lambda, c, mus, zr=zr, limits="vacl", r=r), digits=4) data.frame(mus, arls) # 2. stationary mode, i. e. limits = "stat" ## Monte Carlo results (10^9 replicates) # mu ARL s.e. # 0 500.00 0.0159 # 0.5 22.313 0.0006 # 1 7.2920 0.0001 # 1.5 3.9064 0.0001 # 2 2.5131 0.0000 # 2.5 1.7983 0.0000 # 3 1.4029 0.0000 c <- xewma.crit(lambda, L0, zr=zr, limits="stat", r=r) arls <- round(Mxewma.arl(lambda, c, mus, zr=zr, limits="stat", r=r), digits=4) data.frame(mus, arls) } } \keyword{ts} spc/man/xtewma.sf.Rd0000644000176200001440000000530113553640534014024 0ustar liggesusers\name{xtewma.sf} \alias{xtewma.sf} \title{Compute the survival function of EWMA run length} \description{Computation of the survival function of the Run Length (RL) for EWMA control charts monitoring normal mean.} \usage{xtewma.sf(l, c, df, mu, n, zr=0, hs=0, sided="two", limits="fix", mode="tan", q=1, r=40)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{df}{degrees of freedom -- parameter of the t distribution.} \item{mu}{true mean.} \item{n}{calculate sf up to value \code{n}.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different conrol limits behavior.} \item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently, \code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state situation for the in-control and out-of-control case, respectively, are calculated. Note that mu0=0 is implicitely fixed.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} } \details{ The survival function P(L>n) and derived from it also the cdf P(L<=n) and the pmf P(L=n) illustrate the distribution of the EWMA run length. For large n the geometric tail could be exploited. That is, with reasonable large n the complete distribution is characterized. The algorithm is based on Waldmann's survival function iteration procedure. For varying limits and for change points after 1 the algorithm from Knoth (2004) is applied. For details see Knoth (2004). } \value{Returns a vector which resembles the survival function up to a certain point.} \references{ F. F. Gan (1993), An optimal design of EWMA control charts based on the median run length, \emph{J. Stat. Comput. Simulation 45}, 169-184. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{xewma.sf} for survival function computation of EWMA control charts in the normal case. } \examples{ ## will follow } \keyword{ts} spc/man/xtcusum.arl.Rd0000644000176200001440000000451113553640534014377 0ustar liggesusers\name{xtcusum.arl} \alias{xtcusum.arl} \title{Compute ARLs of CUSUM control charts} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of CUSUM control charts monitoring normal mean.} \usage{xtcusum.arl(k, h, df, mu, hs = 0, sided="one", mode="tan", r=30)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.} \item{df}{degrees of freedom -- parameter of the t distribution.} \item{mu}{true mean.} \item{hs}{so-called headstart (give fast initial response).} \item{sided}{distinguish between one- and two-sided CUSUM schemes by choosing \code{"one"} and \code{"two"}, respectively.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1}.} \item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently, \code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.} } \details{ \code{xtcusum.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature. } \value{Returns a single value which resembles the ARL.} \references{ A. L. Goel, S. M. Wu (1971), Determination of A.R.L. and a contour nomogram for CUSUM charts to control normal mean, \emph{Technometrics 13}, 221-230. D. Brook, D. A. Evans (1972), An approach to the probability distribution of cusum run length, \emph{Biometrika 59}, 539-548. J. M. Lucas, R. B. Crosier (1982), Fast initial response for cusum quality-control schemes: Give your cusum a headstart, \emph{Technometrics 24}, 199-205. L. C. Vance (1986), Average run lengths of cumulative sum control charts for controlling normal means, \emph{Journal of Quality Technology 18}, 189-193. K.-H. Waldmann (1986), Bounds for the distribution of the run length of one-sided and two-sided CUSUM quality control schemes, \emph{Technometrics 28}, 61-67. R. B. Crosier (1986), A new two-sided cumulative quality control scheme, \emph{Technometrics 28}, 187-194. } \author{Sven Knoth} \seealso{ \code{xtewma.arl} for zero-state ARL computation of EWMA control charts and \code{xtcusum.arl} for the zero-state ARL of CUSUM for normal data. } \examples{ ## will follow } \keyword{ts} spc/man/dphat.Rd0000644000176200001440000000611513553640534013214 0ustar liggesusers\name{dphat} \alias{dphat} \alias{pphat} \alias{qphat} \title{Percent defective for normal samples} \description{Density, distribution function and quantile function for the sample percent defective calculated on normal samples with mean equal to \code{mu} and standard deviation equal to \code{sigma}.} \usage{dphat(x, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30) pphat(q, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30) qphat(p, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30)} \arguments{ \item{x, q}{vector of quantiles.} \item{p}{vector of probabilities.} \item{n}{sample size.} \item{mu, sigma}{parameters of the underlying normal distribution.} \item{type}{choose whether the standard deviation is given and fixed (\code{"known"}) or estimated and potententially monitored (\code{"estimated"}).} \item{LSL,USL}{lower and upper specification limit, respectively.} \item{nodes}{number of quadrature nodes needed for \code{type="estimated"}.} } \details{Bruhn-Suhr/Krumbholz (1990) derived the cumulative distribution function of the sample percent defective calculated on normal samples to applying them for a new variables sampling plan. These results were heavily used in Krumbholz/Z\"{o}ller (1995) for Shewhart and in Knoth/Steinmetz (2013) for EWMA control charts. For algorithmic details see, essentially, Bruhn-Suhr/Krumbholz (1990). Two design variants are treated: The simple case, \code{type="known"}, with known normal variance and the presumably much more relevant and considerably intricate case, \code{type="estimated"}, where both parameters of the normal distribution are unknown. Basically, given lower and upper specification limits and the normal distribution, one estimates the expected yield based on a normal sample of size \code{n}. } \value{Returns vector of pdf, cdf or qf values for the statistic phat.} \references{ M. Bruhn-Suhr and W. Krumbholz (1990), A new variables sampling plan for normally distributed lots with unknown standard deviation and double specification limits, \emph{Statistical Papers} 31(1), 195-207. W. Krumbholz and A. Z\"{o}ller (1995), \code{p}-Karten vom Shewhartschen Typ f\"{u}r die messende Pr\"{u}fung, \emph{Allgemeines Statistisches Archiv} 79, 347-360. S. Knoth and S. Steinmetz (2013), EWMA \code{p} charts under sampling by variables, \emph{International Journal of Production Research} 51(13), 3795-3807. } \author{Sven Knoth} \seealso{ \code{phat.ewma.arl} for routines using the herewith considered phat statistic.} \examples{ # Figures 1 (c) and (d) from Knoth/Steinmetz (2013) n <- 5 LSL <- -3 USL <- 3 par(mar=c(5, 5, 1, 1) + 0.1) p.star <- 2*pnorm( (LSL-USL)/2 ) # for p <= p.star pdf and cdf vanish p_ <- seq(p.star+1e-10, 0.07, 0.0001) # define support of Figure 1 # Figure 1 (c) pp_ <- pphat(p_, n) plot(p_, pp_, type="l", xlab="p", ylab=expression(P( hat(p) <= p )), xlim=c(0, 0.06), ylim=c(0,1), lwd=2) abline(h=0:1, v=p.star, col="grey") # Figure 1 (d) dp_ <- dphat(p_, n) plot(p_, dp_, type="l", xlab="p", ylab="f(p)", xlim=c(0, 0.06), ylim=c(0,50), lwd=2) abline(h=0, v=p.star, col="grey") } \keyword{ts}spc/man/p.ewma.arl.Rd0000644000176200001440000000560613553640534014064 0ustar liggesusers\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, sided="upper", lcl=NULL, d.res=1, r.mode="ieee.round", i.mode="integer")} \arguments{ \item{lambda}{smoothing parameter of the EWMA p control chart.} \item{ucl}{upper control limit of the EWMA p control chart.} \item{n}{subgroup size.} \item{p}{(failure/success) rate.} \item{z0}{so-called headstart (give fast initial response).} \item{sided}{distinguishes between one- and two-sided EWMA control chart by choosing \code{"upper"}, \code{"lower"}, and \code{"two"}, respectively.} \item{lcl}{lower control limit of the EWMA p control chart; needed for two-sided design.} \item{d.res}{resolution (see details).} \item{r.mode}{round mode -- allowed modes are \code{"gan.floor"}, \code{"floor"}, \code{"ceil"}, \code{"ieee.round"}, \code{"round"}, \code{"mix"}.} \item{i.mode}{type of interval center -- \code{"integer"} or \code{"half"} integer.} } \details{ The monitored data follow a binomial distribution with size \code{n} and failure/success probability \code{p}. The ARL values of the resulting EWMA control chart are determined by Markov chain approximation. Here, the original EWMA values are approximated by multiples of one over \code{d.res}. Different ways of rounding (see \code{r.mode}) to the next multiple are implemented. Besides Gan's paper nothing is published about the numerical subtleties. } \value{Return single value which resemble the ARL.} \references{ F. F. Gan (1990), Monitoring observations generated from a binomial distribution using modified exponentially weighted moving average control chart, \emph{J. Stat. Comput. Simulation} 37, 45-60. S. Knoth and S. Steinmetz (2013), EWMA \code{p} charts under sampling by variables, \emph{International Journal of Production Research} 51, 3795-3807. } \author{Sven Knoth} \seealso{later.} \examples{ ## Gan (1990) # Table 1 n <- 150 p0 <- .1 z0 <- n*p0 lambda <- c(1, .51, .165) hu <- c(27, 22, 18) p.value <- .1 + (0:20)/200 p.EWMA.arl <- Vectorize(p.ewma.arl, "p") arl1.value <- round(p.EWMA.arl(lambda[1], hu[1], n, p.value, z0, r.mode="round"), digits=2) arl2.value <- round(p.EWMA.arl(lambda[2], hu[2], n, p.value, z0, r.mode="round"), digits=2) arl3.value <- round(p.EWMA.arl(lambda[3], hu[3], n, p.value, z0, r.mode="round"), digits=2) arls <- matrix(c(arl1.value, arl2.value, arl3.value), ncol=length(lambda)) rownames(arls) <- p.value colnames(arls) <- paste("lambda =", lambda) arls ## Knoth/Steinmetz (2013) n <- 5 p0 <- 0.02 z0 <- n*p0 lambda <- 0.3 ucl <- 0.649169922 ## in-control ARL 370.4 (determined with d.res = 2^14 = 16384) res.list <- 2^(1:11) 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/pois.crit.L0L1.Rd0000644000176200001440000000714113555253533014476 0ustar liggesusers\name{pois.cusum.crit.L0L1} \alias{pois.cusum.crit.L0L1} \title{Compute the CUSUM k and h for given in-control ARL L0 and out-of-control ARL L1, Poisson case} \description{Computation of the reference value k and the alarm threshold h for one-sided CUSUM control charts monitoring Poisson data, if the in-control ARL L0 and the out-of-control ARL L1 are given.} \usage{pois.cusum.crit.L0L1(mu0, L0, L1, sided="upper", OUTPUT=FALSE)} \arguments{ \item{mu0}{in-control Poisson mean.} \item{L0}{in-control ARL.} \item{L1}{out-of-control ARL.} \item{sided}{distinguishes between \code{"upper"} and \code{"lower"} CUSUM designs.} \item{OUTPUT}{controls whether iteration details are printed.} } \details{ \code{pois.cusum.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 grid search and using \code{pois.cusum.arl()} and \code{pois.cusum.crit()}. These CUSUM design rules were firstly (and quite rarely afterwards) used by Ewan and Kemp. In the Poisson case, Rossi et al. applied them while analyzing three different normal approximations of the Poisson distribution. See the example which illustrates the validity of all these approaches. } \value{Returns a data frame with results for the denominator \code{m} of the rational approximation, \code{km} as (integer) enumerator of the reference value (approximation), the corresponding out-of-control mean \code{mu1}, the final approximation \code{k} of the reference value, the threshold values \code{hm} (integer) and \code{h} (\code{=hm/m}), and the randomization constant \code{gamma} (the target in-control ARL is exactly matched).} \references{ W. D. Ewan and K. W. Kemp (1960), Sampling inspection of continuous processes with no autocorrelation between successive results, \emph{Biometrika} 47 (3/4), 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} 11(1), 16-31. G. Rossi, L. Lampugnani and M. Marchi (1999), An approximate CUSUM procedure for surveillance of health events, \emph{Statistics in Medicine} 18(16), 2111-2122. } \author{Sven Knoth} \seealso{\code{pois.cusum.arl} for zero-state ARL and \code{pois.cusum.crit} for threshold h computation.} \examples{ ## Table 1 from Rossi et al. (1999) -- one-sided CUSUM La <- 500 # in-control ARL Lr <- 7 # out-of-control ARL m_a <- 0.52 # in-control mean of the Poisson variate \dontrun{kh <- xcusum.crit.L0L1(La, Lr, sided="one")} # instead of deploying EK1960, one could use more accurate numbers EK_k <- 0.60 # EK1960 results in EK_h <- 3.80 # Table 2 on p. 372 eZR <- 2*EK_h # reproduce normal ooc mean from reference value k m_r <- 1.58 # EK1960 Table 3 on p. 377 for m_a = 0.52 R1 <- round( eZR/sqrt(m_a) + 1, digits=2) R2 <- round( ( eZR/2/sqrt(m_a) + 1 )^2, digits=2) R3 <- round(( sqrt(4 + 2*eZR/sqrt(m_a)) - 1 )^2, digits=2) RS <- round( m_r / m_a, digits=2 ) \dontrun{K_hk <- pois.cusum.crit.L0L1(m_a, La, Lr)} # 'our' 'exact' approach K_hk <- data.frame(m=1000, km=948, mu1=1.563777, k=0.948, hm=3832, h=3.832, gamma=0.1201901) # get k for competing means mu0 (m_a) and mu1 (m_r) k_m01 <- function(mu0, mu1) (mu1 - mu0) / (log(mu1) - log(mu0)) # get ooc mean mu1 (m_r) for given mu0 (m_a) and reference value k m1_km0 <- function(mu0, k) { zero <- function(x) k - k_m01(mu0,x) upper <- mu0 + .5 while ( zero(upper) > 0 ) upper <- upper + 0.5 mu1 <- uniroot(zero, c(mu0*1.00000001, upper), tol=1e-9)$root mu1 } K_m_r <- m1_km0(m_a, K_hk$k) RK <- round( K_m_r / m_a, digits=2 ) cat(paste(m_a, R1, R2, R3, RS, RK, "\n", sep="\t")) } \keyword{ts} spc/man/quadrature.nodes.weights.Rd0000644000176200001440000000250613553640534017051 0ustar liggesusers\name{quadrature.nodes.weights} \alias{quadrature.nodes.weights} \title{Calculate quadrature nodes and weights} \description{Computation of the nodes and weights to enable numerical quadrature.} \usage{quadrature.nodes.weights(n, type="GL", x1=-1, x2=1)} \arguments{ \item{n}{number of nodes (and weights).} \item{type}{quadrature type -- currently Gauss-Legendre, \code{"GL"}, and Radau, \code{"Ra"}, are supported.} \item{x1}{lower limit of the integration interval.} \item{x2}{upper limit of the integration interval.} } \details{ A more detailed description will follow soon. The algorithm for the Gauss-Legendre quadrature was delivered by Knut Petras to me, while the one for the Radau quadrature was taken from John Burkardt. } \value{Returns two vectors which hold the needed quadrature nodes and weights.} \references{ H. Brass and K. Petras (2011), \emph{Quadrature Theory. The Theory of Numerical Integration on a Compact Interval,} Mathematical Surveys and Monographs, American Mathematical Society. John Burkardt (2015), \url{https://people.sc.fsu.edu/~jburkardt/f_src/quadrule/quadrule.html} } \author{Sven Knoth} \seealso{ Many of the ARL routines use the Gauss-Legendre nodes. } \examples{ # GL n <- 10 qnw <-quadrature.nodes.weights(n, type="GL") qnw # Radau n <- 10 qnw <-quadrature.nodes.weights(n, type="Ra") qnw } \keyword{ts} spc/man/sewma.q.Rd0000644000176200001440000001061713553640534013471 0ustar liggesusers\name{sewma.q} \alias{sewma.q} \alias{sewma.q.crit} \title{Compute RL quantiles of EWMA (variance charts) control charts} \description{Computation of quantiles of the Run Length (RL) for EWMA control charts monitoring normal variance.} \usage{sewma.q(l, cl, cu, sigma, df, alpha, hs=1, sided="upper", r=40, qm=30) sewma.q.crit(l,L0,alpha,df,sigma0=1,cl=NULL,cu=NULL,hs=1,sided="upper", mode="fixed",ur=4,r=40,qm=30,c.error=1e-12,a.error=1e-9)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{cl}{deployed for \code{sided}=\code{"Rupper"}, that is, upper variance control chart with lower reflecting barrier \code{cl}.} \item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit (\code{mode}=\code{"fixed"}) a value larger than \code{sigma0} has to been given, for all other cases \code{cu} is ignored.} \item{sigma,sigma0}{true and in-control standard deviation, respectively.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{alpha}{quantile level.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}),and \code{"two"} (two-sided chart), respectively.} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit (see \code{cu}) is set and only the lower is calculated to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated).} \item{ur}{truncation of lower chart for \code{classic} mode.} \item{r}{dimension of the resulting linear equation system (highest order of the collocation polynomials).} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} \item{L0}{in-control quantile value.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{a.error}{error bound for the quantile level \code{alpha} during applying the secant rule.} } \details{ Instead of the popular ARL (Average Run Length) quantiles of the EWMA stopping time (Run Length) are determined. The algorithm is based on Waldmann's survival function iteration procedure. Thereby the ideas presented in Knoth (2007) are used. \code{sewma.q.crit} determines the critical values (similar to alarm limits) for given in-control RL quantile \code{L0} at level \code{alpha} by applying secant rule and using \code{sewma.sf()}. In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"} a two-dimensional secant rule is applied that also ensures that the minimum of the cdf for given standard deviation is attained at \code{sigma0}. } \value{Returns a single value which resembles the RL quantile of order \code{alpha} and the lower and upper control limit \code{cl} and \code{cu}, respectively.} \references{ H.-J. Mittag and D. Stemann and B. Tewes (1998), EWMA-Karten zur \"Uberwachung der Streuung von Qualit\"atsmerkmalen, \emph{Allgemeines Statistisches Archiv 82}, 327-338, C. A. Acosta-Mej\'ia and J. J. Pignatiello Jr. and B. V. Rao (1999), A comparison of control charting procedures for monitoring process dispersion, \emph{IIE Transactions 31}, 569-579. S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. S. Knoth (2010), Control Charting Normal Variance -- Reflections, Curiosities, and Recommendations, in \emph{Frontiers in Statistical Quality Control 9}, H.-J. Lenz and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 3-18. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{\code{sewma.arl} for calculation of ARL of variance charts and \code{sewma.sf} for the RL survival function.} \examples{ ## will follow } \keyword{ts} spc/man/imr.RuRl_alone.Rd0000644000176200001440000000705314017417024014736 0ustar liggesusers\name{imr.RuRl_alone} \alias{imr.RuRl_alone} \alias{imr.RuRl_alone_s3} \alias{imr.RuRl_alone_tail} \alias{imr.Ru_Rlgiven} \alias{imr.Rl_Rugiven} \title{Compute control limits of MR charts for normal data} \description{Computation of control limits of standalone MR charts.} \usage{imr.RuRl_alone(L0, N=30, qm=30, M0=12, eps=1e-3) imr.RuRl_alone_s3(L0, N=30, qm=30, M0=12) imr.RuRl_alone_tail(L0, N=30, qm=30, M0=12) imr.Ru_Rlgiven(Rl, L0, N=30, qm=30, M0=12) imr.Rl_Rugiven(Ru, L0, N=30, qm=30, M0=12)} \arguments{ \item{L0}{pre-defined in-control ARL, that is, determine \code{Ru} and \code{Rl} so that the mean number of observations until a false alarm is \code{L0}.} \item{N}{controls the dimension of the linear equation system and consequently the accuracy of the result. See details.} \item{qm}{number of quadrature nodes (and weights) to determine the definite collocation integrals.} \item{M0}{mimics Inf --- by setting \code{M0} to some large value (having a standard normal distribution in mind), the algorithm for IMR charts could be used as well for the standalone MR chart.} \item{eps}{resolution parameter, which controls the approximation of the ARL slope at the in-control level of the monitored standard deviation. It ensures the pattern that is called ARL unbiasedness. A small value is recommended.} \item{Rl}{lower control limit multiple for moving range chart.} \item{Ru}{upper control limit multiple for moving range chart.} } \details{ Crowder (1987a) provided some math to determine the ARL of the so-called individual moving range (IMR) chart, which consists of the mean X chart and the standard deviation MR chart. Making the alarm threshold, \code{M0}, huge (default value here is 12) for the X chart allows us to utilize Crowder's setup for standalone MR charts. For details about the IMR numerics see \code{imr.arl}. The three different versions of \code{imr.RuRl_alone} determine limits that form an ARL unbiased design, follow the restriction \code{Rl} = \code{1/Ru^3} and feature equal probability tails for the MR's half-normal distribution, respectively in the order given above). The other two functions are helper routines for \code{imr.RuRl_alone}. Note that the elegant approach given in Acosta-Mejia/Pignatiello (2000) is only an approximation, because the MR series is not Markovian. } \value{Returns control limit factors (alias multiples).} \references{ S. V. Crowder (1987a) Computation of ARL for Combined Individual Measurement and Moving Range Charts, \emph{Journal of Quality Technology} 19(2), 98-102. S. V. Crowder (1987b) A Program for the Computation of ARL for Combined Individual Measurement and Moving Range Charts, \emph{Journal of Quality Technology} 19(2), 103-106. D. Radson, L. C. Alwan (1995) Detecting Variance Reductions Using the Moving Range, \emph{Quality Engineering} 8(1), 165-178. C. A. Acosta-Mejia, J. J. Pignatiello (2000) Monitoring process dispersion without subgrouping, \emph{Journal of Quality Technology} 32(2), 89-102. } \author{Sven Knoth} \seealso{later.} \examples{ ## Radson, Alwan (1995), Table 2 (Monte Carlo based), half-normal, known parameter case ## two-sided MR-alone chart, hence the ARL results has to be decreased by 1 ## Here: a large M0=12 (default of the functions above) is deployed to mimic Inf alpha <- 0.00915 Ru <- sqrt(2) * qnorm(1-alpha/4) Rl <- sqrt(2) * qnorm(0.5+alpha/4) M0 <- 12 \dontrun{ ARL0 <- imr.arl(M0, Ru, 0, 1, vsided="two", Rl=Rl) RRR1995 <- imr.RuRl_alone_tail(ARL0) RRRs <- imr.RuRl_alone_s3(ARL0) RRR <- imr.RuRl_alone(ARL0) results <- rbind(c(Rl, Ru), RRR1995, RRRs, RRR) results} } \keyword{ts} spc/man/xshewhartrunsrules.arl.Rd0000644000176200001440000001277413553640534016701 0ustar liggesusers\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/xcusum.q.Rd0000644000176200001440000000314713553640534013701 0ustar liggesusers\name{xcusum.q} \alias{xcusum.q} \title{Compute RL quantiles of CUSUM control charts} \description{Computation of quantiles of the Run Length (RL)for CUSUM control charts monitoring normal mean.} \usage{xcusum.q(k, h, mu, alpha, hs=0, sided="one", r=40)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.} \item{mu}{true mean.} \item{alpha}{quantile level.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided CUSUM control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1}.} } \details{ Instead of the popular ARL (Average Run Length) quantiles of the CUSUM stopping time (Run Length) are determined. The algorithm is based on Waldmann's survival function iteration procedure. } \value{Returns a single value which resembles the RL quantile of order \code{q}.} \references{ K.-H. Waldmann (1986), Bounds for the distribution of the run length of one-sided and two-sided CUSUM quality control schemes, \emph{Technometrics 28}, 61-67. } \author{Sven Knoth} \seealso{ \code{xcusum.arl} for zero-state ARL computation of CUSUM control charts. } \examples{ ## Waldmann (1986), one-sided CUSUM, Table 2 ## original values are 345, 82, 9 XCUSUM.Q <- Vectorize("xcusum.q", "alpha") k <- .5 h <- 3 mu <- 0 # corresponds to Waldmann's -0.5 a.list <- c(.95, .5, .05) rl.quantiles <- ceiling(XCUSUM.Q(k, h, mu, a.list)) cbind(a.list, rl.quantiles) } \keyword{ts} spc/man/scusums.arl.Rd0000644000176200001440000000452713553640534014400 0ustar liggesusers\name{scusums.arl} \alias{scusums.arl} \title{Compute ARLs of CUSUM-Shewhart control charts (variance charts)} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of CUSUM-Shewhart combo control charts (based on the sample variance \eqn{S^2}) monitoring normal variance.} \usage{scusums.arl(k, h, cS, sigma, df, hs=0, sided="upper", k2=NULL, h2=NULL, hs2=0, r=40, qm=30, version=2)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.} \item{cS}{Shewhart limit.} \item{sigma}{true standard deviation.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided CUSUM-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart), \code{"lower"} (lower chart), and \code{"two"} (two-sided chart), respectively. Note that for the two-sided chart the parameters \code{"k2"} and \code{"h2"} have to be set too.} \item{k2}{In case of a two-sided CUSUM chart for variance the reference value of the lower chart.} \item{h2}{In case of a two-sided CUSUM chart for variance the decision interval of the lower chart.} \item{hs2}{In case of a two-sided CUSUM chart for variance the headstart of the lower chart.} \item{r}{Dimension of the resulting linear equation system (highest order of the collocation polynomials times number of intervals -- see Knoth 2006).} \item{qm}{Number of quadrature nodes for calculating the collocation definite integrals.} \item{version}{Distinguish version numbers (1,2,...). For internal use only.} } \details{ \code{scusums.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of collocation (piecewise Chebyshev polynomials).} \value{Returns a single value which resembles the ARL.} \references{ S. Knoth (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{scusum.arl} for zero-state ARL computation of standalone CUSUM control charts for monitoring normal variance. } \examples{ ## will follow } \keyword{ts} spc/man/xsewma.arl.Rd0000644000176200001440000000745713553640534014207 0ustar liggesusers\name{xsewma.arl} \alias{xsewma.arl} \title{Compute ARLs of simultaneous EWMA control charts (mean and variance charts)} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of simultaneous EWMA control charts (based on the sample mean and the sample variance \eqn{S^2}) monitoring normal mean and variance.} \usage{xsewma.arl(lx, cx, ls, csu, df, mu, sigma, hsx=0, Nx=40, csl=0, hss=1, Ns=40, s2.on=TRUE, sided="upper", qm=30)} \arguments{ \item{lx}{smoothing parameter lambda of the two-sided mean EWMA chart.} \item{cx}{control limit of the two-sided mean EWMA control chart.} \item{ls}{smoothing parameter lambda of the variance EWMA chart.} \item{csu}{upper control limit of the variance EWMA control chart.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{mu}{true mean.} \item{sigma}{true standard deviation.} \item{hsx}{so-called headstart (enables fast initial response) of the mean chart -- do not confuse with the true FIR feature considered in xewma.arl; will be updated.} \item{Nx}{dimension of the approximating matrix of the mean chart.} \item{csl}{lower control limit of the variance EWMA control chart; default value is 0; not considered if \code{sided} is \code{"upper"}.} \item{hss}{headstart (enables fast initial response) of the variance chart.} \item{Ns}{dimension of the approximating matrix of the variance chart.} \item{s2.on}{distinguishes between \eqn{S^2}{S^2} and \eqn{S}{S} chart.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{qm}{number of quadrature nodes used for the collocation integrals.} } \details{ \code{xsewma.arl} determines the Average Run Length (ARL) by an extension of Gan's (derived from ideas already published by Waldmann) algorithm. The variance EWMA part is treated similarly to the ARL calculation method deployed for the single variance EWMA charts in Knoth (2005), that is, by means of collocation (Chebyshev polynomials). For more details see Knoth (2007).} \value{Returns a single value which resembles the ARL.} \references{ K. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{J. R. Stat. Soc., Ser. C, Appl. Stat. 35}, 151-158. F. F. Gan (1995), Joint monitoring of process mean and variance using exponentially weighted moving average control charts, \emph{Technometrics 37}, 446-453. S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. } \author{Sven Knoth} \seealso{ \code{xewma.arl} and \code{sewma.arl} for zero-state ARL computation of single mean and variance EWMA control charts, respectively. } \examples{ ## Knoth (2007) ## collocation results in Table 1 ## Monte Carlo with 10^9 replicates: 252.307 +/- 0.0078 # process parameters mu <- 0 sigma <- 1 # subgroup size n=5, df=n-1 df <- 4 # lambda of mean chart lx <- .134 # c_mu^* = .345476571 = cx/sqrt(n) * sqrt(lx/(2-lx) cx <- .345476571*sqrt(df+1)/sqrt(lx/(2-lx)) # lambda of variance chart ls <- .1 # c_sigma = .477977 csu <- 1 + .477977 # matrix dimensions for mean and variance part Nx <- 25 Ns <- 25 # mode of variance chart SIDED <- "upper" arl <- xsewma.arl(lx, cx, ls, csu, df, mu, sigma, Nx=Nx, Ns=Ns, sided=SIDED) arl } \keyword{ts} spc/man/pois.ewma.crit.Rd0000644000176200001440000000600513660532510014745 0ustar liggesusers\name{pois.ewma.crit} \alias{pois.ewma.crit} \title{Compute ARLs of Poisson EWMA control charts} \description{Computation of the (zero-state) Average Run Length (ARL) at given mean \code{mu}.} \usage{pois.ewma.crit(lambda, L0, mu0, z0, AU=3, sided="two", design="sym", rando=FALSE, mcdesign="transfer", N=101, jmax=4)} \arguments{ \item{lambda}{smoothing parameter of the EWMA p control chart.} \item{L0}{value of the so-called in-control Average Run Length (ARL) for the Poisson EWMA control chart.} \item{mu0}{in-control mean.} \item{z0}{so-called headstart (give fast initial response).} \item{AU}{in case of the lower chart deployed as reflecting upper barrier -- might be increased step by step until the resulting lower limit does not change anymore.} \item{sided}{distinguishes between one- and two-sided EWMA control chart by choosing \code{"upper"}, \code{"lower"}, and \code{"two"}, respectively.} \item{design}{distinguishes between limits symmetric to the in-control mean \code{mu0} and an ARL-unbiased design (ARL maximum at \code{mu0}); use the shortcuts \code{"sym"} and \code{"unb"}, respectively, please.} \item{rando}{Switch between the standard limit treatment, \code{FALSE}, and an additional randomisation (to allow `perfect' ARL calibration) by setting \code{TRUE}. If randomisation is used, then the corresponding probailities, \code{gL} and \code{gU} are determined, appropriately.} \item{mcdesign}{choose either \code{"classic"} which follows Borror, Champ and Rigdon (1998), or the more sophisticated \code{"transfer"} which improves the accuracy heavily.} \item{N}{number of states of the approximating Markov chain; is equal to the dimension of the resulting linear equation system.} \item{jmax}{number of digits for the to be calculated factors \code{A} (sort of accuracy).} } \details{ The monitored data follow a Poisson distribution with \code{mu}. Here we solve the inverse task to the usual ARL calculation. Hence, determine the control limit factors so that the in-control ARL is (roughly) equal to \code{L0}. The ARL values underneath the routine are determined by Markov chain approximation. The algorithm is just a grid search that takes care of the discrete ARL behavior. } \value{Return one or two values being he control limit factors.} \references{ C. M. Borror, C. W. Champ and S. E. Rigdon (1998) Poisson EWMA control charts, \emph{Journal of Quality Technonlogy} 30(4), 352-361. M. C. Morais and S. Knoth (2020) Improving the ARL profile and the accuracy of its calculation for Poisson EWMA charts, \emph{Quality and Reliability Engineering International} 36(3), 876-889. } \author{Sven Knoth} \seealso{later.} \examples{ ## Borror, Champ and Rigdon (1998), page 30, original value is A = 2.8275 mu0 <- 4 lambda <- 0.2 L0 <- 351 A <- pois.ewma.crit(lambda, L0, mu0, mu0, mcdesign="classic") print(round(A, digits=4)) ## Morais and Knoth (2020), Table 2, lambda = 0.27 column lambda <- 0.27 L0 <- 1233.4 ccgg <- pois.ewma.crit(lambda,1233.4,mu0,mu0,design="unb",rando=TRUE,mcdesign="transfer") print(ccgg, digits=3) } \keyword{ts} spc/man/pois.ewma.ad.Rd0000644000176200001440000000606613660531746014411 0ustar liggesusers\name{pois.ewma.ad} \alias{pois.ewma.ad} \title{Compute steady-state ARLs of Poisson EWMA control charts} \description{Computation of the steady-state Average Run Length (ARL) at given mean \code{mu}.} \usage{pois.ewma.ad(lambda, AL, AU, mu0, mu, sided="two", rando=FALSE, gL=0, gU=0, mcdesign="classic", N=101)} \arguments{ \item{lambda}{smoothing parameter of the EWMA p control chart.} \item{AL, AU}{factors to build the lower and upper control limit, respectively, of the Poisson EWMA control chart.} \item{mu0}{in-control mean.} \item{mu}{actual mean.} \item{sided}{distinguishes between one- and two-sided EWMA control chart by choosing \code{"upper"}, \code{"lower"}, and \code{"two"}, and \code{"zwei"}, respectively.} \item{rando}{Switch between the standard limit treatment, \code{FALSE}, and an additional randomisation (to allow `perfect' ARL calibration) by setting \code{TRUE}. If randomisation is used, then set the corresponding probailities, \code{gL} and \code{gU}, appropriately.} \item{gL, gU}{If the EWMA statistic is at the limit (approximately), then an alarm is triggered with probability \code{gL} and \code{gU} for the lower and upper limit, respectively.} \item{mcdesign}{choose either \code{"classic"} which follows Borror, Champ and Rigdon (1998), or the more sophisticated \code{"transfer"} which improves the accuracy heavily.} \item{N}{number of states of the approximating Markov chain; is equal to the dimension of the resulting linear equation system.} } \details{ The monitored data follow a Poisson distribution with \code{mu}. The ARL values of the resulting EWMA control chart are determined by Markov chain approximation. We follow the algorithm given in Borror, Champ and Rigdon (1998). The function is in an early development phase. } \value{Return single value which resembles the steady-state ARL.} \references{ C. M. Borror, C. W. Champ and S. E. Rigdon (1998) Poisson EWMA control charts, \emph{Journal of Quality Technonlogy} 30(4), 352-361. M. C. Morais and S. Knoth (2020) Improving the ARL profile and the accuracy of its calculation for Poisson EWMA charts, \emph{Quality and Reliability Engineering International} 36(3), 876-889. } \author{Sven Knoth} \seealso{later.} \examples{ ## Borror, Champ and Rigdon (1998), Table 2, PEWMA column mu0 <- 20 lambda <- 0.27 A <- 3.319 mu1 <- c(2*(3:15), 35) ARL1 <- AD1 <- rep(NA, length(mu1)) for ( i in 1:length(mu1) ) { ARL1[i] <- round(pois.ewma.arl(lambda,A,A,mu0,mu0,mu1[i],mcdesign="classic"),digits=1) AD1[i] <- round(pois.ewma.ad(lambda,A,A,mu0,mu1[i],mcdesign="classic"),digits=1) } print( cbind(mu1, ARL1, AD1) ) ## Morais and Knoth (2020), Table 2, lambda = 0.27 column ## randomisation not implemented for pois.ewma.ad() lambda <- 0.27 AL <- 3.0870 AU <- 3.4870 gL <- 0.001029 gU <- 0.000765 mu2 <- c(16, 18, 19.99, mu0, 20.01, 22, 24) ARL2 <- AD2 <- rep(NA, length(mu2)) for ( i in 1:length(mu2) ) { ARL2[i] <- round(pois.ewma.arl(lambda,AL,AU,mu0,mu0,mu2[i],rando=FALSE), digits=1) AD2[i] <- round(pois.ewma.ad(lambda,AL,AU,mu0,mu2[i],rando=FALSE), digits=1) } print( cbind(mu2, ARL2, AD2) ) } \keyword{ts} spc/man/xgrsr.ad.Rd0000644000176200001440000000600213553640534013637 0ustar liggesusers\name{xgrsr.ad} \alias{xgrsr.ad} \title{Compute steady-state ARLs of Shiryaev-Roberts schemes} \description{Computation of the steady-state Average Run Length (ARL) for Shiryaev-Roberts schemes monitoring normal mean.} \usage{xgrsr.ad(k, g, mu1, mu0 = 0, zr = 0, sided = "one", MPT = FALSE, r = 30)} \arguments{ \item{k}{reference value of the Shiryaev-Roberts scheme.} \item{g}{control limit (alarm threshold) of Shiryaev-Roberts scheme.} \item{mu1}{out-of-control mean.} \item{mu0}{in-control mean.} \item{zr}{reflection border to enable the numerical algorithms used here.} \item{sided}{distinguishes between one- and two-sided schemes by choosing \code{"one"} and\code{"two"}, respectively. Currently only one-sided schemes are implemented.} \item{MPT}{switch between the old implementation (\code{FALSE}) and the new one (\code{TRUE}) that considers the completed likelihood ratio. MPT contains the initials of G. Moustakides, A. Polunchenko and A. Tartakovsky.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1}.} } \details{ \code{xgrsr.ad} determines the steady-state Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature. } \value{Returns a single value which resembles the steady-state ARL.} \references{ S. Knoth (2006), The art of evaluating monitoring schemes -- how to measure the performance of control charts? S. Lenz, H. & Wilrich, P. (ed.), \emph{Frontiers in Statistical Quality Control 8}, Physica Verlag, Heidelberg, Germany, 74-99. G. Moustakides, A. Polunchenko, A. Tartakovsky (2009), Numerical comparison of CUSUM and Shiryaev-Roberts procedures for detectin changes in distributions, \emph{Communications in Statistics: Theory and Methods 38}, 3225-3239. } \author{Sven Knoth} \seealso{ \code{xewma.arl} and \code{xcusum-arl} for zero-state ARL computation of EWMA and CUSUM control charts, respectively, and \code{xgrsr.arl} for the zero-state ARL. } \examples{ ## Small study to identify appropriate reflection border to mimic unreflected schemes k <- .5 g <- log(390) zrs <- -(0:10) ZRxgrsr.ad <- Vectorize(xgrsr.ad, "zr") ads <- ZRxgrsr.ad(k, g, 0, zr=zrs) data.frame(zrs, ads) ## Table 2 from Knoth (2006) ## original values are # mu arl # 0 689 # 0.5 30 # 1 8.9 # 1.5 5.1 # 2 3.6 # 2.5 2.8 # 3 2.4 # k <- .5 g <- log(390) zr <- -5 # see first example mus <- (0:6)/2 Mxgrsr.ad <- Vectorize(xgrsr.ad, "mu1") ads <- round(Mxgrsr.ad(k, g, mus, zr=zr), digits=1) data.frame(mus, ads) ## Table 4 from Moustakides et al. (2009) ## original values are # gamma A STADD/steady-state ARL # 50 28.02 4.37 # 100 56.04 5.46 # 500 280.19 8.33 # 1000 560.37 9.64 # 5000 2801.75 12.79 # 10000 5603.7 14.17 Gxgrsr.ad <- Vectorize("xgrsr.ad", "g") As <- c(28.02, 56.04, 280.19, 560.37, 2801.75, 5603.7) gs <- log(As) theta <- 1 zr <- -6 ads <- round(Gxgrsr.ad(theta/2, gs, theta, zr=zr, r=100), digits=2) data.frame(As, ads) } \keyword{ts} spc/man/tol.lim.fact.Rd0000644000176200001440000000476013553640534014412 0ustar liggesusers\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/imr.arl.Rd0000644000176200001440000002265214017400412013445 0ustar liggesusers\name{imr.arl} \alias{imr.arl} \alias{imr.Ru_Mgiven} \alias{imr.Rl_Mgiven} \alias{imr.MandRu} \alias{imr.MandRuRl} \title{Compute ARLs and control limit factors for I-MR combos in case of normal data} \description{Computation of the (zero-state) Average Run Length (ARL) at given mean \code{mu} and \code{sigma} etc.} \usage{imr.arl(M, Ru, mu, sigma, vsided="upper", Rl=0, cmode="coll", N=30, qm=30) imr.Ru_Mgiven(M, L0, N=30, qm=30) imr.Rl_Mgiven(M, L0, N=30, qm=30) imr.MandRu(L0, N=30, qm=30) imr.MandRuRl(L0, N=30, qm=30)} \arguments{ \item{M}{control limit multiple for mean chart.} \item{Ru}{upper control limit multiple for moving range chart.} \item{mu}{actual mean.} \item{sigma}{actual standard deviation.} \item{vsided}{switches between the more common "upper" and the less popular "two"(-sided) case of the MR chart. Setting \code{vsided} to "two" and \code{Ru} sufficiently large (at least \code{2*M}), creates an I-MR chart with a lower limit only for the MR part.} \item{Rl}{lower control limit multiple for moving range chart (not needed in the upper case, i.e. if \code{vsided}="upper").} \item{cmode}{selects the numerical algorithm. The default \code{"coll"} picks the piecewise collocation, which is the most accurate method. Selecting \code{"Crowder"}, the algorithm from Crowder (1987b) is chosen (re-implemented in R). Taking a label from \code{"gl"}, \code{"rectangular"}, \code{"trapezoid"}, \code{"simpson"} or \code{"simpson3_8"}, one decides for the quite common Nystroem procedure to numerically solve the considered integral equation. It is astonishing that Crowder's modified Nystroem design with the trapezoidal quadrature works so well. However, it is clearly dominated by the piecewise collocation algorithm.} \item{N}{Controls the dimension of the linear equation system and consequently the accuracy of the result. See details.} \item{qm}{Number of quadrature nodes (and weights) to determine the collocation definite integrals.} \item{L0}{pre-defined in-control ARL, that is, determine \code{Ru}, \code{Rl}, or \code{M} and \code{Ru} or all of them (essentially ending in a lower limit MR chart) so that the mean number of observations until a false alarm is \code{L0}.} } \details{ Crowder (1987a) provided some math to determine the ARL of the so-called individual moving range (IMR) chart. The given integral equation was approximated by a linear equation system applying trapezoidal quadratures. Interestingly, Crowder did not recognize the specific behavior of the solution for \code{Ru} >= \code{M} (which is the more common case), where the resulting function L() is constant in the central part of the considered domain. In addition, by performing collocation on two (\code{Ru} > \code{M}) or three (\code{Ru} < \code{M}) subintervals piecewise, one obtains highly accurate ARL numbers. Note that \code{imr.MandRu} yields \code{M} and \code{Ru} for the upper MR trace, whereas \code{imr.MandRuRl} provides in addition the lower factor \code{Rl} for IMR consisting of two two-sided control charts. Note that the underlying ARL unbiased condition suppresses the upper limit \code{Ru} in all considered cases so far. This is not completely surprising, because the mean chart is already quite sensitive for increases in the variance. The two functions \code{imr.Ru_Mgiven} and \code{imr.Rl_Mgiven} deliver the single upper and lower limit, respectively, if a one-sided MR design is utilized and the control lmit factor \code{M} of the mean chart is set already. Note that for \code{Ru} > \code{2*M}, the upper MR limit is not operative anymore. If it was initially an upper MR chart, then it reduces to a single mean chart. If it was originally a two-sided MR design, then it becomes a two-sided mean/lower variance chart combo. Within the latter scheme, the mean chart signals variance increases (a well-known pattern), whereas the MR subchart delivers only decreasing variance signals. However, these simple Shewhart charts exhibit in all configurations week variance decreases detection behavior. Eventually, we should note that the scientific control chart community mainly recommends to ignore MR charts, see, for example, Vardeman and Jobe (2016), whereas standards (such as ISO), commercial SPC software and many training manuals provide the IMR scheme with completely wrong upper limits for the MR chart.} \value{Returns either the ARL or control limit factors (alias multiples).} \references{ S. V. Crowder (1987a) Computation of ARL for Combined Individual Measurement and Moving Range Charts, \emph{Journal of Quality Technology} 19(2), 98-102. S. V. Crowder (1987b) A Program for the Computation of ARL for Combined Individual Measurement and Moving Range Charts, \emph{Journal of Quality Technology} 19(2), 103-106. K. C. B. Roes, R. J. M. M. Does, Y. Schurink, Shewhart-Type Control Charts for Individual Observations, \emph{Journal of Quality Technology} 25(3), 188-198. S. E. Rigdon, E. N. Cruthis, C. W. Champ (1994) Design Strategies for Individuals and Moving Range Control Charts, \emph{Journal of Quality Technology} 26(4), 274-287. D. Radson, L. C. Alwan (1995) Detecting Variance Reductions Using the Moving Range, \emph{Quality Engineering} 8(1), 165-178. S. R. Adke, X. Hong (1997) A Supplementary Test Based on the Control Chart for Individuals, \emph{Journal of Quality Technology} 29(1), 16-20. R. W. Amin, R. A. Ethridge (1998) A Note on Individual and Moving Range Control Charts, \emph{Journal of Quality Technology} 30(1), 70-74. C. A. Acosta-Mejia, J. J. Pignatiello (2000) Monitoring process dispersion without subgrouping, \emph{Journal of Quality Technology} 32(2), 89-102. N. B. Marks, T. C. Krehbiel (2011) Design And Application Of Individuals And Moving Range Control Charts, \emph{Journal of Applied Business Research ({JABR})} 25(5), 31-40. D. Rahardja (2014) Comparison of Individual and Moving Range Chart Combinations to Individual Charts in Terms of ARL after Designing for a Common ``All OK'' ARL, \emph{Journal of Modern Applied Statistical Methods} 13(2), 364-378. S. B. Vardeman, J. M. Jobe (2016) \emph{Statistical Methods for Quality Assurance}, Springer, 2nd edition. } \author{Sven Knoth} \seealso{later.} \examples{ ## Crowder (1987b), Output Listing 1, trapezoidal quadrature (less accurate) M <- 2 Ru <- 3 mu <- seq(0, 2, by=0.25) LL <- LL2 <- rep(NA, length(mu)) for ( i in 1:length(mu) ) { LL[i] <- round( imr.arl(M, Ru, mu[i], 1), digits=4) LL2[i] <- round( imr.arl(M, Ru, mu[i], 1, cmode="Crowder", N=80), digits=4) } LL1987b <- c(18.2164, 16.3541, 12.4282, 8.7559, 6.1071, 4.3582, 3.2260, 2.4878, 1.9989) print( data.frame(mu, LL2, LL1987b, LL) ) ## Crowder (1987a), Table 1, trapezoidal quadrature (less accurate) M <- 4 Ru <- 3 mu <- seq(0, 2, by=0.25) LL <- rep(NA, length(mu)) for ( i in 1:length(mu) ) LL[i] <- round( imr.arl(M, Ru, mu[i], 1), digits=4) LL1987a <- c(34.44, 34.28, 34.07, 33.81, 33.45, 32.82, 31.50, 28.85, 24.49) print( data.frame(mu, LL1987a, LL) ) ## Rigdon, Cruthis, Champ (1994), Table 1, Monte Carlo based M <- 2.992 Ru <- 4.139 icARL <- imr.arl(M, Ru, 0, 1) icARL1994 <- 200 print( data.frame(icARL1994, icARL) ) M <- 3.268 Ru <- 4.556 icARL <- imr.arl(M, Ru, 0, 1) icARL1994 <- 500 print( data.frame(icARL1994, icARL) ) ## ..., Table 2, Monte Carlo based M <- 2.992 Ru <- 4.139 tau <- c(seq(1, 1.3, by=0.05), seq(1.4, 2, by=0.1)) LL <- rep(NA, length(tau)) for ( i in 1:length(tau) ) LL[i] <- round( imr.arl(M, Ru, 0, tau[i]), digits=2) LL1994 <- c(200.54, 132.25, 90.84, 65.66, 49.35, 38.92, 31.11, 21.35, 15.47, 12.04, 9.81, 8.21, 7.03, 6.14) print( data.frame(tau, LL1994, LL) ) ## Radson, Alwan (1995), Table 2 (Monte Carlo based), half-normal, known parameter case ## two-sided (!) MR-alone (!) chart, hence the ARL results has to be decreased by 1 ## Here: a large M (=12) is deployed to mimic Inf alpha <- 0.00915 Ru <- sqrt(2) * qnorm(1-alpha/4) Rl <- sqrt(2) * qnorm(0.5+alpha/4) k <- 1.5 - (0:7)/10 LL <- rep(NA, length(k)) for ( i in 1:length(k) ) LL[i] <- round( imr.arl(12, Ru, 0, k[i], vsided="two", Rl=Rl), digits=2) - 1 RA1995 <- c(18.61, 24.51, 34.21, 49.74, 75.08, 113.14, 150.15, 164.54) print( data.frame(k, RA1995, LL) ) ## Amin, Ethridge (1998), Table 2, column sigma/sigma_0 = 1.00 M <- 3.27 Ru <- 4.56 #M <- 3.268 #Ru <- 4.556 mu <- seq(0, 2, by=0.25) LL <- rep(NA, length(mu)) for ( i in 1:length(mu) ) LL[i] <- round( imr.arl(M, Ru, mu[i], 1), digits=1) LL1998 <- c(505.3, 427.6, 276.7, 156.2, 85.0, 46.9, 26.9, 16.1, 10.1) print( data.frame(mu, LL1998, LL) ) ## ..., column sigma/sigma_0 = 1.05 for ( i in 1:length(mu) ) LL[i] <- round( imr.arl(M, Ru, mu[i], 1.05), digits=1) LL1998 <- c(296.8, 251.6, 169.6, 101.6, 58.9, 34.5, 20.9, 13.2, 8.7) print( data.frame(mu, LL1998, LL) ) ## Acosta-Mejia, Pignatiello (2000), Table 2 ## AMP utilized Markov chain approximation ## However, the MR series is not Markovian! ## MR-alone (!) chart, hence the ARL results has to be decreased by 1 ## Here: a large M (=8) is deployed to mimic Inf Ru <- 3.93 sigma <- c(1, 1.05, 1.1, 1.15, 1.2, 1.3, 1.4, 1.5, 1.75) LL <- rep(NA, length(sigma)) for ( i in 1:length(sigma) ) LL[i] <- round( imr.arl(8, Ru, 0, sigma[i], N=30), digits=1) - 1 AMP2000 <- c(201.0, 136.8, 97.9, 73.0, 56.3, 36.4, 25.6, 19.1, 11.0) print( data.frame(sigma, AMP2000, LL) ) ## Mark, Krehbiel (2011), Table 2, deployment of Crowder (1987b), nominal ic ARL 500 M <- c(3.09, 3.20, 3.30, 3.50, 4.00) Ru <- c(6.00, 4.67, 4.53, 4.42, 4.36) LL0 <- rep(NA, length(M)) for ( i in 1:length(M) ) LL0[i] <- round( imr.arl(M[i], Ru[i], 0, 1), digits=1) print( data.frame(M, Ru, LL0) ) } \keyword{ts} spc/man/xDshewhartrunsrules.arl.Rd0000644000176200001440000000647713553640534017010 0ustar liggesusers\name{xDshewhartrunsrules.arl} \alias{xDshewhartrunsrules.arl} \alias{xDshewhartrunsrulesFixedm.arl} \title{Compute ARLs of Shewhart control charts with and without runs rules under drift} \description{Computation of the zero-state Average Run Length (ARL) under drift for Shewhart control charts with and without runs rules monitoring normal mean.} \usage{xDshewhartrunsrules.arl(delta, c = 1, m = NULL, type = "12") xDshewhartrunsrulesFixedm.arl(delta, c = 1, m = 100, type = "12") } \arguments{ \item{delta}{true drift parameter.} \item{c}{normalizing constant to ensure specific alarming behavior.} \item{type}{controls the type of Shewhart chart used, seed details section.} \item{m}{parameter of Gan's approach. If \code{m=NULL}, then \code{m} will increased until the resulting ARL does not change anymore.} } \details{ Based on Gan (1991), the ARL is calculated for Shewhart control charts with and without runs rules under drift. The usual ARL function with mu=m*delta is determined and recursively via m-1, m-2, ... 1 (or 0) the drift ARL determined. \code{xDshewhartrunsrulesFixedm.arl} is the actual work horse, while \code{xDshewhartrunsrules.arl} provides a convenience wrapper. Note that Aerne et al. (1991) deployed a method that is quite similar to Gan's algorithm. For \code{type} see the help page of \code{xshewhartrunsrules.arl}. } \value{Returns a single value which resembles the ARL.} \references{ F. F. Gan (1991), EWMA control chart under linear drift, \emph{J. Stat. Comput. Simulation 38}, 181-200. L. A. Aerne, C. W. Champ and S. E. Rigdon (1991), Evaluation of control charts under linear trend, \emph{Commun. Stat., Theory Methods 20}, 3341-3349. } \author{Sven Knoth} \seealso{ \code{xshewhartrunsrules.arl} for zero-state ARL computation of Shewhart control charts with and without runs rules for the classical step change model. } \examples{ ## Aerne et al. (1991) ## Table I (continued) ## original numbers are # delta arl1of1 arl2of3 arl4of5 arl10 # 0.005623 136.67 120.90 105.34 107.08 # 0.007499 114.98 101.23 88.09 89.94 # 0.010000 96.03 84.22 73.31 75.23 # 0.013335 79.69 69.68 60.75 62.73 # 0.017783 65.75 57.38 50.18 52.18 # 0.023714 53.99 47.06 41.33 43.35 # 0.031623 44.15 38.47 33.99 36.00 # 0.042170 35.97 31.36 27.91 29.90 # 0.056234 29.21 25.51 22.91 24.86 # 0.074989 23.65 20.71 18.81 20.70 # 0.100000 19.11 16.79 15.45 17.29 # 0.133352 15.41 13.61 12.72 14.47 # 0.177828 12.41 11.03 10.50 12.14 # 0.237137 9.98 8.94 8.71 10.18 # 0.316228 8.02 7.25 7.26 8.45 # 0.421697 6.44 5.89 6.09 6.84 # 0.562341 5.17 4.80 5.15 5.48 # 0.749894 4.16 3.92 4.36 4.39 # 1.000000 3.35 3.22 3.63 3.52 c1of1 <- 3.069/3 c2of3 <- 2.1494/2 c4of5 <- 1.14 c10 <- 3.2425/3 DxDshewhartrunsrules.arl <- Vectorize(xDshewhartrunsrules.arl, "delta") deltas <- 10^(-(18:0)/8) arl1of1 <- round(DxDshewhartrunsrules.arl(deltas, c=c1of1, type="1"), digits=2) arl2of3 <- round(DxDshewhartrunsrules.arl(deltas, c=c2of3, type="12"), digits=2) arl4of5 <- round(DxDshewhartrunsrules.arl(deltas, c=c4of5, type="13"), digits=2) arl10 <- round(DxDshewhartrunsrules.arl(deltas, c=c10, type="SameSide10"), digits=2) data.frame(delta=round(deltas, digits=6), arl1of1, arl2of3, arl4of5, arl10) } \keyword{ts} spc/man/xcusum.ad.Rd0000644000176200001440000000535513553640534014030 0ustar liggesusers\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/xewma.q.Rd0000644000176200001440000001022613553640534013472 0ustar liggesusers\name{xewma.q} \alias{xewma.q} \alias{xewma.q.crit} \title{Compute RL quantiles of EWMA control charts} \description{Computation of quantiles of the Run Length (RL) for EWMA control charts monitoring normal mean.} \usage{xewma.q(l, c, mu, alpha, zr=0, hs=0, sided="two", limits="fix", q=1, r=40) xewma.q.crit(l, L0, mu, alpha, zr=0, hs=0, sided="two", limits="fix", r=40, c.error=1e-12, a.error=1e-9, OUTPUT=FALSE)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{mu}{true mean.} \item{alpha}{quantile level.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different control limits behavior.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\geq)}, will be determined. Note that mu0=0 is implicitely fixed.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} \item{L0}{in-control quantile value.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{a.error}{error bound for the quantile level \code{alpha} during applying the secant rule.} \item{OUTPUT}{activate or deactivate additional output.} } \details{ Instead of the popular ARL (Average Run Length) quantiles of the EWMA stopping time (Run Length) are determined. The algorithm is based on Waldmann's survival function iteration procedure. If \code{limits} is not \code{"fix"}, then the method presented in Knoth (2003) is utilized. Note that for one-sided EWMA charts (\code{sided}=\code{"one"}), only \code{"vacl"} and \code{"stat"} are deployed, while for two-sided ones (\code{sided}=\code{"two"}) also \code{"fir"}, \code{"both"} (combination of \code{"fir"} and \code{"vacl"}), and \code{"Steiner"} are implemented. For details see Knoth (2004). } \value{Returns a single value which resembles the RL quantile of order \code{q}.} \references{ F. F. Gan (1993), An optimal design of EWMA control charts based on the median run length, \emph{J. Stat. Comput. Simulation 45}, 169-184. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. S. Knoth (2015), Run length quantiles of EWMA control charts monitoring normal mean or/and variance, \emph{International Journal of Production Research 53}, 4629-4647. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL computation of EWMA control charts. } \examples{ ## Gan (1993), two-sided EWMA with fixed control limits ## some values of his Table 1 -- any median RL should be 500 XEWMA.Q <- Vectorize("xewma.q", c("l", "c")) G.lambda <- c(.05, .1, .15, .2, .25) G.h <- c(.441, .675, .863, 1.027, 1.177) MEDIAN <- ceiling(XEWMA.Q(G.lambda, G.h/sqrt(G.lambda/(2-G.lambda)), 0, .5, sided="two")) print(cbind(G.lambda, MEDIAN)) ## increase accuracy of thresholds # (i) calculate threshold for given in-control median value by # deplyoing secant rule XEWMA.q.crit <- Vectorize("xewma.q.crit", "l") # (ii) re-calculate the thresholds and remove the standardization step L0 <- 500 G.h.new <- XEWMA.q.crit(G.lambda, L0, 0, .5, sided="two") G.h.new <- round(G.h.new * sqrt(G.lambda/(2-G.lambda)), digits=5) # (iii) compare Gan's original values and the new ones with 5 digits print(cbind(G.lambda, G.h.new, G.h)) # (iv) calculate the new medians MEDIAN <- ceiling(XEWMA.Q(G.lambda, G.h.new/sqrt(G.lambda/(2-G.lambda)), 0, .5, sided="two")) print(cbind(G.lambda, MEDIAN)) } \keyword{ts} spc/man/euklid.ewma.arl.Rd0000644000176200001440000000265614325474642015107 0ustar liggesusers\name{euklid.ewma.arl} \alias{euklid.ewma.arl} \title{Compute ARLs of Poisson NCS-EWMA control charts} \description{Computation of the (zero-state) Average Run Length (ARL) at given Poisson mean \code{mu}.} \usage{euklid.ewma.arl(gX, gY, kL, kU, mu, y0, r0=0)} \arguments{ \item{gX}{first and} \item{gY}{second integer forming the rational lambda = gX/(gX+gY), lambda mimics the usual EWMA smoothing constant.} \item{kL}{lower control limit of the NCS-EWMA control chart, integer.} \item{kU}{upper control limit of the NCS-EWMA control chart, integer.} \item{mu}{mean value of Poisson distribution.} \item{y0}{headstart like value -- it is proposed to use the in-control mean.} \item{r0}{further element of the headstart -- deviating from the default should be done only in case of full understanding of the scheme.} } \details{ A new idea of applying EWMA smoothing to count data based on integer divison with remainders. It is highly recommended to read the corresponding paper (see below). } \value{Return single value which resemble the ARL.} \references{ A. C. Rakitzis, P. Castagliola, P. E. Maravelakis (2015), A new memory-type monitoring technique for count data, Computers and Industrial Engineering 85, 235-247. } \author{Sven Knoth} \seealso{later.} \examples{ # RCM (2015), Table 12, page 243, first NCS column gX <- 5 gY <- 24 kL <- 16 kU <- 24 mu0 <- 20 #L0 <- euklid.ewma.arl(gX, gY, kL, kU, mu0, mu0) # should be 1219.2 } \keyword{ts} spc/man/xDewma.arl.Rd0000644000176200001440000002253713553640534014124 0ustar liggesusers\name{xDewma.arl} \alias{xDewma.arl} \title{Compute ARLs of EWMA control charts under drift} \description{Computation of the (zero-state and other) Average Run Length (ARL) under drift for different types of EWMA control charts monitoring normal mean.} \usage{xDewma.arl(l, c, delta, zr = 0, hs = 0, sided = "one", limits = "fix", mode = "Gan", m = NULL, q = 1, r = 40, with0 = FALSE)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{delta}{true drift parameter.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguish between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different control limits behavior.} \item{mode}{decide whether Gan's or Knoth's approach is used. Use \code{"Gan"} and \code{"Knoth"}, respectively.} \item{m}{parameter used if \code{mode="Gan"}. \code{m} is design parameter of Gan's approach. If \code{m=NULL}, then \code{m} will increased until the resulting ARL does not change anymore.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\geq)}, will be determined. Note that mu0=0 is implicitely fixed. Deploy large \code{q} to mimic steady-state. It works only for \code{mode="Knoth"}.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} \item{with0}{defines whether the first observation used for the RL calculation follows already 1*delta or still 0*delta. With \code{q} additional flexibility is given.} } \details{ Based on Gan (1991) or Knoth (2003), the ARL is calculated for EWMA control charts under drift. In case of Gan's framework, the usual ARL function with mu=m*delta is determined and recursively via m-1, m-2, ... 1 (or 0) the drift ARL determined. The framework of Knoth allows to calculate ARLs for varying parameters, such as control limits and distributional parameters. For details see the cited papers. } \value{Returns a single value which resembles the ARL.} \references{ F. F. Gan (1991), EWMA control chart under linear drift, \emph{J. Stat. Comput. Simulation 38}, 181-200. L. A. Aerne, C. W. Champ and S. E. Rigdon (1991), Evaluation of control charts under linear trend, \emph{Commun. Stat., Theory Methods 20}, 3341-3349. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. H. M. Fahmy and E. A. Elsayed (2006), Detection of linear trends in process mean, \emph{International Journal of Production Research 44}, 487-504. S. Knoth (2012), More on Control Charting under Drift, in: \emph{Frontiers in Statistical Quality Control 10}, H.-J. Lenz, W. Schmid and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 53-68. C. Zou, Y. Liu and Z. Wang (2009), Comparisons of control schemes for monitoring the means of processes subject to drifts, \emph{Metrika 70}, 141-163. } \author{Sven Knoth} \seealso{ \code{xewma.arl} and \code{xewma.ad} for zero-state and steady-state ARL computation of EWMA control charts for the classical step change model. } \examples{ \dontrun{ DxDewma.arl <- Vectorize(xDewma.arl, "delta") ## Gan (1991) ## Table 1 ## original values are # delta arlE1 arlE2 arlE3 # 0 500 500 500 # 0.0001 482 460 424 # 0.0010 289 231 185 # 0.0020 210 162 129 # 0.0050 126 94.6 77.9 # 0.0100 81.7 61.3 52.7 # 0.0500 27.5 21.8 21.9 # 0.1000 17.0 14.2 15.3 # 1.0000 4.09 4.28 5.25 # 3.0000 2.60 2.90 3.43 # lambda1 <- 0.676 lambda2 <- 0.242 lambda3 <- 0.047 h1 <- 2.204/sqrt(lambda1/(2-lambda1)) h2 <- 1.111/sqrt(lambda2/(2-lambda2)) h3 <- 0.403/sqrt(lambda3/(2-lambda3)) deltas <- c(.0001, .001, .002, .005, .01, .05, .1, 1, 3) arlE10 <- round(xewma.arl(lambda1, h1, 0, sided="two"), digits=2) arlE1 <- c(arlE10, round(DxDewma.arl(lambda1, h1, deltas, sided="two", with0=TRUE), digits=2)) arlE20 <- round(xewma.arl(lambda2, h2, 0, sided="two"), digits=2) arlE2 <- c(arlE20, round(DxDewma.arl(lambda2, h2, deltas, sided="two", with0=TRUE), digits=2)) arlE30 <- round(xewma.arl(lambda3, h3, 0, sided="two"), digits=2) arlE3 <- c(arlE30, round(DxDewma.arl(lambda3, h3, deltas, sided="two", with0=TRUE), digits=2)) data.frame(delta=c(0, deltas), arlE1, arlE2, arlE3) ## do the same with more digits for the alarm threshold L0 <- 500 h1 <- xewma.crit(lambda1, L0, sided="two") h2 <- xewma.crit(lambda2, L0, sided="two") h3 <- xewma.crit(lambda3, L0, sided="two") lambdas <- c(lambda1, lambda2, lambda3) hs <- c(h1, h2, h3) * sqrt(lambdas/(2-lambdas)) hs # compare with Gan's values 2.204, 1.111, 0.403 round(hs, digits=3) arlE10 <- round(xewma.arl(lambda1, h1, 0, sided="two"), digits=2) arlE1 <- c(arlE10, round(DxDewma.arl(lambda1, h1, deltas, sided="two", with0=TRUE), digits=2)) arlE20 <- round(xewma.arl(lambda2, h2, 0, sided="two"), digits=2) arlE2 <- c(arlE20, round(DxDewma.arl(lambda2, h2, deltas, sided="two", with0=TRUE), digits=2)) arlE30 <- round(xewma.arl(lambda3, h3, 0, sided="two"), digits=2) arlE3 <- c(arlE30, round(DxDewma.arl(lambda3, h3, deltas, sided="two", with0=TRUE), digits=2)) data.frame(delta=c(0, deltas), arlE1, arlE2, arlE3) ## Aerne et al. (1991) -- two-sided EWMA ## Table I (continued) ## original numbers are # delta arlE1 arlE2 arlE3 # 0.000000 465.0 465.0 465.0 # 0.005623 77.01 85.93 102.68 # 0.007499 64.61 71.78 85.74 # 0.010000 54.20 59.74 71.22 # 0.013335 45.20 49.58 58.90 # 0.017783 37.76 41.06 48.54 # 0.023714 31.54 33.95 39.87 # 0.031623 26.36 28.06 32.68 # 0.042170 22.06 23.19 26.73 # 0.056234 18.49 19.17 21.84 # 0.074989 15.53 15.87 17.83 # 0.100000 13.07 13.16 14.55 # 0.133352 11.03 10.94 11.88 # 0.177828 9.33 9.12 9.71 # 0.237137 7.91 7.62 7.95 # 0.316228 6.72 6.39 6.52 # 0.421697 5.72 5.38 5.37 # 0.562341 4.88 4.54 4.44 # 0.749894 4.18 3.84 3.68 # 1.000000 3.58 3.27 3.07 # lambda1 <- .133 lambda2 <- .25 lambda3 <- .5 cE1 <- 2.856 cE2 <- 2.974 cE3 <- 3.049 deltas <- 10^(-(18:0)/8) arlE10 <- round(xewma.arl(lambda1, cE1, 0, sided="two"), digits=2) arlE1 <- c(arlE10, round(DxDewma.arl(lambda1, cE1, deltas, sided="two"), digits=2)) arlE20 <- round(xewma.arl(lambda2, cE2, 0, sided="two"), digits=2) arlE2 <- c(arlE20, round(DxDewma.arl(lambda2, cE2, deltas, sided="two"), digits=2)) arlE30 <- round(xewma.arl(lambda3, cE3, 0, sided="two"), digits=2) arlE3 <- c(arlE30, round(DxDewma.arl(lambda3, cE3, deltas, sided="two"), digits=2)) data.frame(delta=c(0, round(deltas, digits=6)), arlE1, arlE2, arlE3) ## Fahmy/Elsayed (2006) -- two-sided EWMA ## Table 4 (Monte Carlo results, 10^4 replicates, change point at t=51!) ## original numbers are # delta arl s.e. # 0.00 365.749 3.598 # 0.10 12.971 0.029 # 0.25 7.738 0.015 # 0.50 5.312 0.009 # 0.75 4.279 0.007 # 1.00 3.680 0.006 # 1.25 3.271 0.006 # 1.50 2.979 0.005 # 1.75 2.782 0.004 # 2.00 2.598 0.005 # lambda <- 0.1 cE <- 2.7 deltas <- c(.1, (1:8)/4) arlE1 <- c(round(xewma.arl(lambda, cE, 0, sided="two"), digits=3), round(DxDewma.arl(lambda, cE, deltas, sided="two"), digits=3)) arlE51 <- c(round(xewma.arl(lambda, cE, 0, sided="two", q=51)[51], digits=3), round(DxDewma.arl(lambda, cE, deltas, sided="two", mode="Knoth", q=51), digits=3)) data.frame(delta=c(0, deltas), arlE1, arlE51) ## additional Monte Carlo results with 10^8 replicates # delta arl.q=1 s.e. arl.q=51 s.e. # 0.00 368.910 0.036 361.714 0.038 # 0.10 12.986 0.000 12.781 0.000 # 0.25 7.758 0.000 7.637 0.000 # 0.50 5.318 0.000 5.235 0.000 # 0.75 4.285 0.000 4.218 0.000 # 1.00 3.688 0.000 3.628 0.000 # 1.25 3.274 0.000 3.233 0.000 # 1.50 2.993 0.000 2.942 0.000 # 1.75 2.808 0.000 2.723 0.000 # 2.00 2.616 0.000 2.554 0.000 ## Zou et al. (2009) -- one-sided EWMA ## Table 1 ## original values are # delta arl1 arl2 arl3 # 0 ~ 1730 # 0.0005 317 377 440 # 0.001 215 253 297 # 0.005 83.6 92.6 106 # 0.01 55.6 58.8 66.1 # 0.05 22.6 21.1 22.0 # 0.1 15.5 13.9 13.8 # 0.5 6.65 5.56 5.09 # 1.0 4.67 3.83 3.43 # 2.0 3.21 2.74 2.32 # 3.0 2.86 2.06 1.98 # 4.0 2.14 2.00 1.83 l1 <- 0.03479 l2 <- 0.11125 l3 <- 0.23052 c1 <- 2.711 c2 <- 3.033 c3 <- 3.161 zr <- -6 r <- 50 deltas <- c(0.0005, 0.001, 0.005, 0.01, 0.05, 0.1, 0.5, 1:4) arl1 <- c(round(xewma.arl(l1, c1, 0, zr=zr, r=r), digits=2), round(DxDewma.arl(l1, c1, deltas, zr=zr, r=r), digits=2)) arl2 <- c(round(xewma.arl(l2, c2, 0, zr=zr), digits=2), round(DxDewma.arl(l2, c2, deltas, zr=zr, r=r), digits=2)) arl3 <- c(round(xewma.arl(l3, c3, 0, zr=zr, r=r), digits=2), round(DxDewma.arl(l3, c3, deltas, zr=zr, r=r), digits=2)) data.frame(delta=c(0, deltas), arl1, arl2, arl3) } } \keyword{ts} spc/man/xsresewma.arl.Rd0000644000176200001440000001644513553640534014716 0ustar liggesusers\name{x.res.ewma.arl} \alias{x.res.ewma.arl} \alias{s.res.ewma.arl} \alias{xs.res.ewma.arl} \alias{xs.res.ewma.pms} \title{Compute ARLs of EWMA residual control charts} \description{Computation of the (zero-state) Average Run Length (ARL) for EWMA residual control charts monitoring normal mean, variance, or mean and variance simultaneously. Additionally, the probability of misleading signals (PMS) is calculated.} \usage{x.res.ewma.arl(l, c, mu, alpha=0, n=5, hs=0, r=40) s.res.ewma.arl(l, cu, sigma, mu=0, alpha=0, n=5, hs=1, r=40, qm=30) xs.res.ewma.arl(lx, cx, ls, csu, mu, sigma, alpha=0, n=5, hsx=0, rx=40, hss=1, rs=40, qm=30) xs.res.ewma.pms(lx, cx, ls, csu, mu, sigma, type="3", alpha=0, n=5, hsx=0, rx=40, hss=1, rs=40, qm=30) } \arguments{ \item{l, lx, ls}{smoothing parameter(s) lambda of the EWMA control chart.} \item{c, cu, cx, csu}{critical value (similar to alarm limit) of the EWMA control charts.} \item{mu}{true mean.} \item{sigma}{true standard deviation.} \item{alpha}{the AR(1) coefficient -- first order autocorrelation of the original data.} \item{n}{batch size.} \item{hs, hsx, hss}{so-called headstart (enables fast initial response).} \item{r, rx, rs}{number of quadrature nodes or size of collocation base, dimension of the resulting linear equation system is equal to \code{r} (two-sided).} \item{qm}{number of nodes for collocation quadratures.} \item{type}{PMS type, for \code{PMS}="3" (the default) the probability of getting a mean signal despite the variance changed, and for \code{PMS}="4" the opposite case is dealt with.} } \details{ The above list of functions provides the application of algorithms developed for iid data to the residual case. To be more precise, the underlying model is a sequence of normally distributed batches with size \code{n} with autocorrelation within the batch and independence between the batches (see also the references below). It is restricted to the classical EWMA chart types, that is two-sided for the mean, upper charts for the variance, and all equipped with fixed limits. The autocorrelation is modeled by an AR(1) process with parameter \code{alpha}. Additionally, with \code{xs.res.ewma.pms} the probability of misleading signals (PMS) of \code{type} is calculated. This is offered exclusively in this small collection so that for iid data this function has to be used too (with \code{alpha=0}). } \value{Return single values which resemble the ARL and the PMS, respectively.} \references{ S. Knoth, M. C. Morais, A. Pacheco, W. Schmid (2009), Misleading Signals in Simultaneous Residual Schemes for the Mean and Variance of a Stationary Process, \emph{Commun. Stat., Theory Methods 38}, 2923-2943. S. Knoth, W. Schmid, A. Schoene (2001), Simultaneous Shewhart-Type Charts for the Mean and the Variance of a Time Series, \emph{Frontiers of Statistical Quality Control 6, A. Lenz, H.-J. & Wilrich, P.-T. (Eds.)}, 6, 61-79. S. Knoth, W. Schmid (2002) Monitoring the mean and the variance of a stationary process, \emph{Statistica Neerlandica 56}, 77-100. } \author{Sven Knoth} \seealso{ \code{xewma.arl}, \code{sewma.arl}, and \code{xsewma.arl} as more elaborated functions in the iid case.} \examples{ \dontrun{ ## S. Knoth, W. Schmid (2002) cat("\nFragments of Table 2 (n=5, lambda.1=lambda.2)\n") lambdas <- c(.5, .25, .1, .05) L0 <- 500 n <- 5 crit <- NULL for ( lambda in lambdas ) { cs <- xsewma.crit(lambda, lambda, L0, n-1) x.e <- round(cs[1], digits=4) names(x.e) <- NULL s.e <- round((cs[3]-1) * sqrt((2-lambda)/lambda)*sqrt((n-1)/2), digits=4) names(s.e) <- NULL crit <- rbind(crit, data.frame(lambda, x.e, s.e)) } ## orinal values are (Markov chain approximation with 50 states) # lambda x.e s.e # 0.50 3.2765 4.6439 # 0.25 3.2168 4.0149 # 0.10 3.0578 3.3376 # 0.05 2.8817 2.9103 print(crit) cat("\nFragments of Table 4 (n=5, lambda.1=lambda.2=0.1)\n\n") lambda <- .1 # the algorithm used in Knoth/Schmid is less accurate -- proceed with their values cx <- x.e <- 3.0578 s.e <- 3.3376 csu <- 1 + s.e * sqrt(lambda/(2-lambda))*sqrt(2/(n-1)) alpha <- .3 a.values <- c((0:6)/4, 2) d.values <- c(1 + (0:5)/10, 1.75 , 2) arls <- NULL for ( delta in d.values ) { row <- NULL for ( mu in a.values ) { arl <- round(xs.res.ewma.arl(lambda, cx, lambda, csu, mu*sqrt(n), delta, alpha=alpha, n=n), digits=2) names(arl) <- NULL row <- c(row, arl) } arls <- rbind(arls, data.frame(t(row))) } names(arls) <- a.values rownames(arls) <- d.values ## orinal values are (now Monte-Carlo with 10^6 replicates) # 0 0.25 0.5 0.75 1 1.25 1.5 2 #1 502.44 49.50 14.21 7.93 5.53 4.28 3.53 2.65 #1.1 73.19 32.91 13.33 7.82 5.52 4.29 3.54 2.66 #1.2 24.42 18.88 11.37 7.44 5.42 4.27 3.54 2.67 #1.3 13.11 11.83 9.09 6.74 5.18 4.17 3.50 2.66 #1.4 8.74 8.31 7.19 5.89 4.81 4.00 3.41 2.64 #1.5 6.50 6.31 5.80 5.08 4.37 3.76 3.28 2.59 #1.75 3.94 3.90 3.78 3.59 3.35 3.09 2.83 2.40 #2 2.85 2.84 2.80 2.73 2.63 2.51 2.39 2.14 print(arls) ## S. Knoth, M. C. Morais, A. Pacheco, W. Schmid (2009) cat("\nFragments of Table 5 (n=5, lambda=0.1)\n\n") d.values <- c(1.02, 1 + (1:5)/10, 1.75 , 2) arl.x <- arl.s <- arl.xs <- PMS.3 <- NULL for ( delta in d.values ) { arl.x <- c(arl.x, round(x.res.ewma.arl(lambda, cx/delta, 0, n=n), digits=3)) arl.s <- c(arl.s, round(s.res.ewma.arl(lambda, csu, delta, n=n), digits=3)) arl.xs <- c(arl.xs, round(xs.res.ewma.arl(lambda, cx, lambda, csu, 0, delta, n=n), digits=3)) PMS.3 <- c(PMS.3, round(xs.res.ewma.pms(lambda, cx, lambda, csu, 0, delta, n=n), digits=6)) } ## orinal values are (Markov chain approximation) # delta arl.x arl.s arl.xs PMS.3 # 1.02 833.086 518.935 323.324 0.381118 # 1.10 454.101 84.208 73.029 0.145005 # 1.20 250.665 25.871 24.432 0.071024 # 1.30 157.343 13.567 13.125 0.047193 # 1.40 108.112 8.941 8.734 0.035945 # 1.50 79.308 6.614 6.493 0.029499 # 1.75 44.128 3.995 3.942 0.021579 # 2.00 28.974 2.887 2.853 0.018220 print(cbind(delta=d.values, arl.x, arl.s, arl.xs, PMS.3)) cat("\nFragments of Table 6 (n=5, lambda=0.1)\n\n") alphas <- c(-0.9, -0.5, -0.3, 0, 0.3, 0.5, 0.9) deltas <- c(0.05, 0.25, 0.5, 0.75, 1, 1.25, 1.5, 2) PMS.4 <- NULL for ( ir in 1:length(deltas) ) { mu <- deltas[ir]*sqrt(n) pms <- NULL for ( alpha in alphas ) { pms <- c(pms, round(xs.res.ewma.pms(lambda, cx, lambda, csu, mu, 1, type="4", alpha=alpha, n=n), digits=6)) } PMS.4 <- rbind(PMS.4, data.frame(delta=deltas[ir], t(pms))) } names(PMS.4) <- c("delta", alphas) rownames(PMS.4) <- NULL ## orinal values are (Markov chain approximation) # delta -0.9 -0.5 -0.3 0 0.3 0.5 0.9 # 0.05 0.055789 0.224521 0.279842 0.342805 0.391299 0.418915 0.471386 # 0.25 0.003566 0.009522 0.014580 0.025786 0.044892 0.066584 0.192023 # 0.50 0.002994 0.001816 0.002596 0.004774 0.009259 0.015303 0.072945 # 0.75 0.006967 0.000703 0.000837 0.001529 0.003400 0.006424 0.046602 # 1.00 0.005098 0.000402 0.000370 0.000625 0.001589 0.003490 0.039978 # 1.25 0.000084 0.000266 0.000202 0.000300 0.000867 0.002220 0.039773 # 1.50 0.000000 0.000256 0.000120 0.000163 0.000531 0.001584 0.042734 # 2.00 0.000000 0.000311 0.000091 0.000056 0.000259 0.001029 0.054543 print(PMS.4) } } \keyword{ts} spc/man/mewma.crit.Rd0000644000176200001440000000324213553640534014160 0ustar liggesusers\name{mewma.crit} \alias{mewma.crit} \title{Compute alarm threshold of MEWMA control charts} \description{Computation of the alarm threshold for multivariate exponentially weighted moving average (MEWMA) charts monitoring multivariate normal mean.} \usage{mewma.crit(l, L0, p, hs=0, r=20)} \arguments{ \item{l}{smoothing parameter lambda of the MEWMA control chart.} \item{L0}{in-control ARL.} \item{p}{dimension of multivariate normal distribution.} \item{hs}{so-called headstart (enables fast initial response) -- must be non-negative.} \item{r}{number of quadrature nodes -- dimension of the resulting linear equation system.} } \details{ \code{mewma.crit} determines the alarm threshold of for given in-control ARL \code{L0} by applying secant rule and using \code{mewma.arl()} with \code{ntype="gl2"}. } \value{Returns a single value which resembles the critical value \code{c}.} \references{ Sven Knoth (2017), ARL Numerics for MEWMA Charts, \emph{Journal of Quality Technology 49(1)}, 78-89. Steven E. Rigdon (1995), An integral equation for the in-control average run length of a multivariate exponentially weighted moving average control chart, \emph{J. Stat. Comput. Simulation 52(4)}, 351-365. } \author{Sven Knoth} \seealso{\code{mewma.arl} for zero-state ARL computation.} \examples{ # Rigdon (1995), p. 358, Tab. 1 p <- 4 L0 <- 500 r <- .25 h4 <- mewma.crit(r, L0, p) h4 ## original value is 16.38. # Knoth (2017), p. 82, Tab. 2 p <- 3 L0 <- 1e3 lambda <- c(0.25, 0.2, 0.15, 0.1, 0.05) h4 <- rep(NA, length(lambda) ) for ( i in 1:length(lambda) ) h4[i] <- mewma.crit(lambda[i], L0, p, r=20) round(h4, digits=2) ## original values are ## 15.82 15.62 15.31 14.76 13.60 } \keyword{ts} spc/man/sewma.sf.prerun.Rd0000644000176200001440000000507013553640534015150 0ustar liggesusers\name{sewma.sf.prerun} \alias{sewma.sf.prerun} \title{Compute the survival function of EWMA run length} \description{Computation of the survival function of the Run Length (RL) for EWMA control charts monitoring normal variance.} \usage{sewma.sf.prerun(n, l, cl, cu, sigma, df1, df2, hs=1, sided="upper", qm=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE)} \arguments{ \item{n}{calculate sf up to value \code{n}.} \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{cl}{lower control limit of the EWMA control chart.} \item{cu}{upper control limit of the EWMA control chart.} \item{sigma}{true standard deviation.} \item{df1}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{df2}{degrees of freedom of the pre-run variance estimator.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of \code{cl} is not used), \code{"Rupper"} (upper chart with reflection at \code{cl}), \code{"Rlower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{qm}{number of quadrature nodes for calculating the collocation definite integrals.} \item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.} \item{truncate}{size of truncated tail.} \item{tail_approx}{Controls whether the geometric tail approximation is used (is faster) or not.} } \details{ The survival function P(L>n) and derived from it also the cdf P(L<=n) and the pmf P(L=n) illustrate the distribution of the EWMA run length. For large n the geometric tail could be exploited. That is, with reasonable large n the complete distribution is characterized. The algorithm is based on Waldmann's survival function iteration procedure and on results in Knoth (2007)... } \value{Returns a vector which resembles the survival function up to a certain point.} \references{ S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{sewma.sf} for the RL survival function of EWMA control charts w/o pre-run uncertainty. } \examples{ ## will follow } \keyword{ts} spc/man/xsewma.q.Rd0000644000176200001440000001017713553640534013662 0ustar liggesusers\name{xsewma.q} \alias{xsewma.q} \alias{xsewma.q.crit} \title{Compute critical values of simultaneous EWMA control charts (mean and variance charts) for given RL quantile} \description{Computation of the critical values (similar to alarm limits) for different types of simultaneous EWMA control charts (based on the sample mean and the sample variance \eqn{S^2}) monitoring normal mean and variance.} \usage{xsewma.q(lx, cx, ls, csu, df, alpha, mu, sigma, hsx=0, Nx=40, csl=0, hss=1, Ns=40, sided="upper", qm=30) xsewma.q.crit(lx, ls, L0, alpha, df, mu0=0, sigma0=1, csu=NULL, hsx=0, hss=1, sided="upper", mode="fixed", Nx=20, Ns=40, qm=30, c.error=1e-12, a.error=1e-9)} \arguments{ \item{lx}{smoothing parameter lambda of the two-sided mean EWMA chart.} \item{cx}{control limit of the two-sided mean EWMA control chart.} \item{ls}{smoothing parameter lambda of the variance EWMA chart.} \item{csu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit (\code{mode}=\code{"fixed"}, only for \code{xsewma.q.crit}) a value larger than \code{sigma0} has to been given, for all other cases \code{cu} is ignored. It is the upper control limit of the variance EWMA control chart.} \item{L0}{in-control RL quantile at level \code{alpha}.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{alpha}{quantile level.} \item{mu}{true mean.} \item{sigma}{true standard deviation.} \item{mu0}{in-control mean.} \item{sigma0}{in-control standard deviation.} \item{hsx}{so-called headstart (enables fast initial response) of the mean chart -- do not confuse with the true FIR feature considered in xewma.arl; will be updated.} \item{Nx}{dimension of the approximating matrix of the mean chart.} \item{csl}{lower control limit of the variance EWMA control chart; default value is 0; not considered if \code{sided} is \code{"upper"}.} \item{hss}{headstart (enables fast initial response) of the variance chart.} \item{Ns}{dimension of the approximating matrix of the variance chart.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart without reflection at \code{cl} -- the actual value of of \code{cl} is not used).} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit (see \code{cu}) is set and only the lower is determined to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated).} \item{qm}{number of quadrature nodes used for the collocation integrals.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{a.error}{error bound for the quantile level \code{alpha} during applying the secant rule.} } \details{ Instead of the popular ARL (Average Run Length) quantiles of the EWMA stopping time (Run Length) are determined. The algorithm is based on Waldmann's survival function iteration procedure and on Knoth (2007). \code{xsewma.q.crit} determines the critical values (similar to alarm limits) for given in-control RL quantile \code{L0} at level \code{alpha} by applying secant rule and using \code{xsewma.sf()}. In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"} a two-dimensional secant rule is applied that also ensures that the maximum of the RL cdf for given standard deviation is attained at \code{sigma0}. } \value{Returns a single value which resembles the RL quantile of order \code{alpha} and the critical value of the two-sided mean EWMA chart and the lower and upper controls limit \code{csl} and \code{csu} of the variance EWMA chart, respectively.} \references{ S. Knoth (2007), Accurate ARL calculation for EWMA control charts monitoring simultaneously normal mean and variance, \emph{Sequential Analysis 26}, 251-264. } \author{Sven Knoth} \seealso{\code{xsewma.arl} for calculation of ARL of simultaneous EWMA charts and \code{xsewma.sf} for the RL survival function.} \examples{ ## will follow } \keyword{ts} spc/man/xewma.sf.prerun.Rd0000644000176200001440000001035213553640534015154 0ustar liggesusers\name{xewma.sf.prerun} \alias{xewma.sf.prerun} \title{Compute the survival function of EWMA run length in case of estimated parameters} \description{Computation of the survival function of the Run Length (RL) for EWMA control charts monitoring normal mean if the in-control mean, standard deviation, or both are estimated by a pre run.} \usage{xewma.sf.prerun(l, c, mu, n, zr=0, hs=0, sided="one", limits="fix", q=1, size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE, bound=1e-10)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{mu}{true mean.} \item{n}{calculate sf up to value \code{n}.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (give fast initial response).} \item{sided}{distinguish between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguish between different control limits behavior.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state situation for the in-control and out-of-control case, respectively, are calculated. Note that mu0=0 is implicitely fixed.} \item{size}{pre run sample size.} \item{df}{degrees of freedom of the pre run variance estimator. Typically it is simply \code{size} - 1. If the pre run is collected in batches, then also other values are needed.} \item{estimated}{name the parameter to be estimated within the \code{"mu"}, \code{"sigma"}, \code{"both"}.} \item{qm.mu}{number of quadrature nodes for convoluting the mean uncertainty.} \item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.} \item{truncate}{size of truncated tail.} \item{tail_approx}{Controls whether the geometric tail approximation is used (is faster) or not.} \item{bound}{control when the geometric tail kicks in; the larger the quicker and less accurate; \code{bound} should be larger than 0 and less than 0.001.} } \details{ The survival function P(L>n) and derived from it also the cdf P(L<=n) and the pmf P(L=n) illustrate the distribution of the EWMA run length... } \value{Returns a vector which resembles the survival function up to a certain point.} \references{ F. F. Gan (1993), An optimal design of EWMA control charts based on the median run length, \emph{J. Stat. Comput. Simulation 45}, 169-184. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. L. A. Jones, C. W. Champ, S. E. Rigdon (2001), The performance of exponentially weighted moving average charts with estimated parameters, \emph{Technometrics 43}, 156-167. K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. } \author{Sven Knoth} \seealso{ \code{xewma.sf} for the RL survival function of EWMA control charts w/o pre run uncertainty. } \examples{ ## Jones/Champ/Rigdon (2001) c4m <- function(m, n) sqrt(2)*gamma( (m*(n-1)+1)/2 )/sqrt( m*(n-1) )/gamma( m*(n-1)/2 ) n <- 5 # sample size # Figure 6, subfigure r=0.1 lambda <- 0.1 L <- 2.454 CDF0 <- 1 - xewma.sf(lambda, L, 0, 600, sided="two") m <- 10 # pre run size CDF1 <- 1 - xewma.sf.prerun(lambda, L/c4m(m,n), 0, 600, sided="two", size=m, df=m*(n-1), estimated="both") m <- 20 CDF2 <- 1 - xewma.sf.prerun(lambda, L/c4m(m,n), 0, 600, sided="two", size=m, df=m*(n-1), estimated="both") m <- 50 CDF3 <- 1 - xewma.sf.prerun(lambda, L/c4m(m,n), 0, 600, sided="two", size=m, df=m*(n-1), estimated="both") plot(CDF0, type="l", xlab="t", ylab=expression(P(T<=t)), xlim=c(0,500), ylim=c(0,1)) abline(v=0, h=c(0,1), col="grey", lwd=.7) points((1:5)*100, CDF0[(1:5)*100], pch=18) lines(CDF1, col="blue") points((1:5)*100, CDF1[(1:5)*100], pch=2, col="blue") lines(CDF2, col="red") points((1:5)*100, CDF2[(1:5)*100], pch=16, col="red") lines(CDF3, col="green") points((1:5)*100, CDF3[(1:5)*100], pch=5, col="green") legend("bottomright", c("Known", "m=10, n=5", "m=20, n=5", "m=50, n=5"), col=c("black", "blue", "red", "green"), pch=c(18, 2, 16, 5), lty=1) } \keyword{ts} spc/man/xtewma.arl.Rd0000644000176200001440000000674113553640534014203 0ustar liggesusers\name{xtewma.arl} \alias{xtewma.arl} \title{Compute ARLs of EWMA control charts, t distributed data} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of EWMA control charts monitoring the mean of t distributed data.} \usage{xtewma.arl(l,c,df,mu,zr=0,hs=0,sided="two",limits="fix",mode="tan",q=1,r=40)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{df}{degrees of freedom -- parameter of the t distribution.} \item{mu}{true mean.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguishes between different control limits behavior.} \item{mode}{Controls the type of variables substitution that might improve the numerical performance. Currently, \code{"identity"}, \code{"sin"}, \code{"sinh"}, and \code{"tan"} (default) are provided.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\ge q)}, will be determined. Note that mu0=0 is implicitely fixed.} \item{r}{number of quadrature nodes, dimension of the resulting linear equation system is equal to \code{r+1} (one-sided) or \code{r} (two-sided).} } \details{ In case of the EWMA chart with fixed control limits, \code{xtewma.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of the Nystroem method based on Gauss-Legendre quadrature. If \code{limits} is \code{"vacl"}, then the method presented in Knoth (2003) is utilized. Other values (normal case) for \code{limits} are not yet supported. } \value{Except for the fixed limits EWMA charts it returns a single value which resembles the ARL. For fixed limits charts, it returns a vector of length \code{q} which resembles the ARL and the sequence of conditional expected delays for \code{q}=1 and \code{q}>1, respectively.} \references{ K.-H. Waldmann (1986), Bounds for the distribution of the run length of geometric moving average charts, \emph{Appl. Statist. 35}, 151-158. S. V. Crowder (1987), A simple method for studying run-length distributions of exponentially weighted moving average charts, \emph{Technometrics 29}, 401-407. J. M. Lucas and M. S. Saccucci (1990), Exponentially weighted moving average control schemes: Properties and enhancements, \emph{Technometrics 32}, 1-12. C. M. Borror, D. C. Montgomery, and G. C. Runger (1999), Robustness of the EWMA control chart to non-normality , \emph{Journal of Quality Technology 31}, 309-316. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for zero-state ARL computation of EWMA control charts in the normal case. } \examples{ ## Borror/Montgomery/Runger (1999), Table 3 lambda <- 0.1 cE <- 2.703 df <- c(4, 6, 8, 10, 15, 20, 30, 40, 50) L0 <- rep(NA, length(df)) for ( i in 1:length(df) ) { L0[i] <- round(xtewma.arl(lambda, cE*sqrt(df[i]/(df[i]-2)), df[i], 0), digits=0) } data.frame(df, L0) } \keyword{ts} spc/man/pois.cusum.crit.Rd0000644000176200001440000000612013555254177015163 0ustar liggesusers\name{pois.cusum.crit} \alias{pois.cusum.crit} \title{Compute alarm thresholds and randomization constants of Poisson CUSUM control charts} \description{Computation of the CUSUM upper limit and, if needed, of the randomization probability, given mean \code{mu0}.} \usage{pois.cusum.crit(mu0, km, A, m, i0=0, sided="upper", rando=FALSE)} \arguments{ \item{mu0}{actual in-control mean.} \item{km}{enumerator of rational approximation of reference value \code{k}.} \item{A}{target in-control ARL (average run length).} \item{m}{denominator of rational approximation of reference value.} \item{i0}{head start value as integer multiple of \code{1/m}; should be an element of \code{0:100} (a more reasonable upper limit will be established soon). It is planned, to set \code{i0} as a fraction of the final threshold.} \item{sided}{distinguishes between different one- and two-sided CUSUM control chart by choosing \code{"upper"}, \code{"lower"} and \code{"two"}, respectively.} \item{rando}{Switch for activating randomization in order to allow continuous ARL control.} } \details{ The monitored data follow a Poisson distribution with \code{mu} (here the in-control level \code{mu0}). The ARL values of the resulting EWMA control chart are determined via Markov chain calculations. With some grid search, we obtain the smallest value for the integer threshold component \code{hm} so that the resulting ARL is not smaller than \code{A}. If equality is needed, then activating \code{rando=TRUE} yields the corresponding randomization probability \code{gamma}. More details will follow in a paper that will be submitted in 2020. } \value{Returns two single values, integer threshold \code{hm} resulting in the final alarm threshold \code{h=hm/m}, and the randomization probability.} \references{ J. M. Lucas (1985) Counted data CUSUM's, \emph{Technometrics} 27(2), 129-144. C. H. White and J. B. Keats (1996) ARLs and Higher-Order Run-Length Moments for the Poisson CUSUM, \emph{Journal of Quality Technology} 28(3), 363-369. C. H. White, J. B. Keats and J. Stanley (1997) Poisson CUSUM versus c chart for defect data, \emph{Quality Engineering} 9(4), 673-679. G. Rossi and L. Lampugnani and M. Marchi (1999), An approximate CUSUM procedure for surveillance of health events, \emph{Statistics in Medicine} 18(16), 2111-2122. S. W. Han, K.-L. Tsui, B. Ariyajunya, and S. B. Kim (2010), A comparison of CUSUM, EWMA, and temporal scan statistics for detection of increases in poisson rates, \emph{Quality and Reliability Engineering International} 26(3), 279-289. M. B. Perry and J. J. Pignatiello Jr. (2011) Estimating the time of step change with Poisson CUSUM and EWMA control charts, \emph{International Journal of Production Research} 49(10), 2857-2871. } \author{Sven Knoth} \seealso{later.} \examples{ ## Lucas 1985 mu0 <- 0.25 km <- 1 A <- 430 m <- 4 #cv <- pois.cusum.crit(mu0, km, A, m) cv <- c(40, 0) # Lucas reported h = 10 alias hm = 40 (in Table 2, first block, row 10.0 .25 .0 ..., column 1.0 # Recall that Lucas and other trigger an alarm, if the CUSUM statistic is greater than # or equal to the alarm threshold h print(cv) } \keyword{ts} spc/man/xcusum.crit.L0L1.Rd0000644000176200001440000000653613553640534015056 0ustar liggesusers\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/lns2ewma.crit.Rd0000644000176200001440000000734013553640534014605 0ustar liggesusers\name{lns2ewma.crit} \alias{lns2ewma.crit} \title{Compute critical values of EWMA ln \eqn{S^2}{S^2} control charts (variance charts)} \description{Computation of the critical values (similar to alarm limits) for different types of EWMA control charts (based on the log of the sample variance \eqn{S^2}) monitoring normal variance.} \usage{lns2ewma.crit(l,L0,df,sigma0=1,cl=NULL,cu=NULL,hs=NULL,sided="upper",mode="fixed",r=40)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{L0}{in-control ARL.} \item{df}{actual degrees of freedom, corresponds to subsample size (for known mean it is equal to the subsample size, for unknown mean it is equal to subsample size minus one.} \item{sigma0}{in-control standard deviation.} \item{cl}{deployed for \code{sided}=\code{"upper"}, that is, upper variance control chart with lower reflecting barrier \code{cl}.} \item{cu}{for two-sided (\code{sided}=\code{"two"}) and fixed upper control limit (\code{mode}=\code{"fixed"}), for all other cases \code{cu} is ignored.} \item{hs}{so-called headstart (enables fast initial response) -- the default value (hs=NULL) corresponds to the in-control mean of ln \eqn{S^2}{S^2}.} \item{sided}{distinguishes between one- and two-sided two-sided EWMA-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart with reflection at \code{cl}), \code{"lower"} (lower chart with reflection at \code{cu}), and \code{"two"} (two-sided chart), respectively.} \item{mode}{only deployed for \code{sided}=\code{"two"} -- with \code{"fixed"} an upper control limit (see \code{cu}) is set and only the lower is calculated to obtain the in-control ARL \code{L0}, while with \code{"unbiased"} a certain unbiasedness of the ARL function is guaranteed (here, both the lower and the upper control limit are calculated). With \code{"vanilla"} limits symmetric around the in-control mean of ln \eqn{S^2}{S^2} are determined, while for \code{"eq.tails"} the in-control ARL values of two single EWMA variance charts (decompose the two-sided scheme into one lower and one upper scheme) are matched.} \item{r}{dimension of the resulting linear equation system: the larger the more accurate.} } \details{ \code{lns2ewma.crit} determines the critical values (similar to alarm limits) for given in-control ARL \code{L0} by applying secant rule and using \code{lns2ewma.arl()}. In case of \code{sided}=\code{"two"} and \code{mode}=\code{"unbiased"} a two-dimensional secant rule is applied that also ensures that the maximum of the ARL function for given standard deviation is attained at \code{sigma0}. See Knoth (2010) and the related example. } \value{Returns the lower and upper control limit \code{cl} and \code{cu}.} \references{ C. A. Acosta-Mej\'ia and J. J. Pignatiello Jr. and B. V. Rao (1999), A comparison of control charting procedures for monitoring process dispersion, \emph{IIE Transactions 31}, 569-579. S. V. Crowder and M. D. Hamilton (1992), An EWMA for monitoring a process standard deviation, \emph{Journal of Quality Technology 24}, 12-21. S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2010), Control Charting Normal Variance -- Reflections, Curiosities, and Recommendations, in \emph{Frontiers in Statistical Quality Control 9}, H.-J. Lenz and P.-T. Wilrich (Eds.), Physica Verlag, Heidelberg, Germany, 3-18. } \author{Sven Knoth} \seealso{\code{lns2ewma.arl} for calculation of ARL of EWMA ln \eqn{S^2}{S^2} control charts.} \examples{ ## Knoth (2005) ## compare with 1.05521 mentioned on page 350 third line from below L0 <- 200 lambda <- .05 df <- 4 limits <- lns2ewma.crit(lambda, L0, df, cl=0, hs=0) limits["cu"]/sqrt( lambda/(2-lambda)*(2/df+2/df^2+4/3/df^3-16/15/df^5) ) } \keyword{ts} spc/man/xewma.arl.prerun.Rd0000644000176200001440000001050013553640534015315 0ustar liggesusers\name{xewma.arl.prerun} \alias{xewma.arl.prerun} \alias{xewma.crit.prerun} \title{Compute ARLs of EWMA control charts in case of estimated parameters} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of EWMA control charts monitoring normal mean if the in-control mean, standard deviation, or both are estimated by a pre run.} \usage{xewma.arl.prerun(l, c, mu, zr=0, hs=0, sided="two", limits="fix", q=1, size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10) xewma.crit.prerun(l, L0, mu, zr=0, hs=0, sided="two", limits="fix", size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, c.error=1e-12, L.error=1e-9, OUTPUT=FALSE)} \arguments{ \item{l}{smoothing parameter lambda of the EWMA control chart.} \item{c}{critical value (similar to alarm limit) of the EWMA control chart.} \item{mu}{true mean shift.} \item{zr}{reflection border for the one-sided chart.} \item{hs}{so-called headstart (give fast initial response).} \item{sided}{distinguish between one- and two-sided EWMA control chart by choosing \code{"one"} and \code{"two"}, respectively.} \item{limits}{distinguish between different control limits behavior.} \item{q}{change point position. For \eqn{q=1} and \eqn{\mu=\mu_0} and \eqn{\mu=\mu_1}, the usual zero-state ARLs for the in-control and out-of-control case, respectively, are calculated. For \eqn{q>1} and \eqn{\mu!=0} conditional delays, that is, \eqn{E_q(L-q+1|L\ge q)}, will be determined. Note that mu0=0 is implicitely fixed.} \item{size}{pre run sample size.} \item{df}{Degrees of freedom of the pre run variance estimator. Typically it is simply \code{size} - 1. If the pre run is collected in batches, then also other values are needed.} \item{estimated}{name the parameter to be estimated within the \code{"mu"}, \code{"sigma"}, \code{"both"}.} \item{qm.mu}{number of quadrature nodes for convoluting the mean uncertainty.} \item{qm.sigma}{number of quadrature nodes for convoluting the standard deviation uncertainty.} \item{truncate}{size of truncated tail.} \item{L0}{in-control ARL.} \item{c.error}{error bound for two succeeding values of the critical value during applying the secant rule.} \item{L.error}{error bound for the ARL level \code{L0} during applying the secant rule.} \item{OUTPUT}{activate or deactivate additional output.} } \details{ Essentially, the ARL function \code{xewma.arl} is convoluted with the distribution of the sample mean, standard deviation or both. For details see Jones/Champ/Rigdon (2001) and Knoth (2014?). } \value{Returns a single value which resembles the ARL.} \references{ L. A. Jones, C. W. Champ, S. E. Rigdon (2001), The performance of exponentially weighted moving average charts with estimated parameters, \emph{Technometrics 43}, 156-167. S. Knoth (2003), EWMA schemes with non-homogeneous transition kernels, \emph{Sequential Analysis 22}, 241-255. S. Knoth (2004), Fast initial response features for EWMA Control Charts, \emph{Statistical Papers 46}, 47-64. S. Knoth (2014?), tbd, \emph{tbd}, tbd-tbd. } \author{Sven Knoth} \seealso{ \code{xewma.arl} for the usual zero-state ARL computation. } \examples{ ## Jones/Champ/Rigdon (2001) c4m <- function(m, n) sqrt(2)*gamma( (m*(n-1)+1)/2 )/sqrt( m*(n-1) )/gamma( m*(n-1)/2 ) n <- 5 # sample size m <- 20 # pre run with 20 samples of size n = 5 C4m <- c4m(m, n) # needed for bias correction # Table 1, 3rd column lambda <- 0.2 L <- 2.636 xewma.ARL <- Vectorize("xewma.arl", "mu") xewma.ARL.prerun <- Vectorize("xewma.arl.prerun", "mu") mu <- c(0, .25, .5, 1, 1.5, 2) ARL <- round(xewma.ARL(lambda, L, mu, sided="two"), digits=2) p.ARL <- round(xewma.ARL.prerun(lambda, L/C4m, mu, sided="two", size=m, df=m*(n-1), estimated="both", qm.mu=70), digits=2) # Monte-Carlo with 10^8 repetitions: 200.325 (0.020) and 144.458 (0.022) cbind(mu, ARL, p.ARL) \dontrun{ # Figure 5, subfigure r = 0.2 mu_ <- (0:85)/40 ARL_ <- round(xewma.ARL(lambda, L, mu_, sided="two"), digits=2) p.ARL_ <- round(xewma.ARL.prerun(lambda, L/C4m, mu_, sided="two", size=m, df=m*(n-1), estimated="both"), digits=2) plot(mu_, ARL_, type="l", xlab=expression(delta), ylab="ARL", xlim=c(0,2)) abline(v=0, h=0, col="grey", lwd=.7) points(mu, ARL, pch=5) lines(mu_, p.ARL_, col="blue") points(mu, p.ARL, pch=18, col ="blue") legend("topright", c("Known", "Estimated"), col=c("black", "blue"), lty=1, pch=c(5, 18)) } } \keyword{ts} spc/man/scusum.arl.Rd0000644000176200001440000000620713553640534014212 0ustar liggesusers\name{scusum.arl} \alias{scusum.arl} \title{Compute ARLs of CUSUM control charts (variance charts)} \description{Computation of the (zero-state) Average Run Length (ARL) for different types of CUSUM control charts (based on the sample variance \eqn{S^2}) monitoring normal variance.} \usage{scusum.arl(k, h, sigma, df, hs=0, sided="upper", k2=NULL, h2=NULL, hs2=0, r=40, qm=30, version=2)} \arguments{ \item{k}{reference value of the CUSUM control chart.} \item{h}{decision interval (alarm limit, threshold) of the CUSUM control chart.} \item{sigma}{true standard deviation.} \item{df}{actual degrees of freedom, corresponds to subgroup size (for known mean it is equal to the subgroup size, for unknown mean it is equal to subgroup size minus one.} \item{hs}{so-called headstart (enables fast initial response).} \item{sided}{distinguishes between one- and two-sided two-sided CUSUM-\eqn{S^2}{S^2} control charts by choosing \code{"upper"} (upper chart), \code{"lower"} (lower chart), and \code{"two"} (two-sided chart), respectively. Note that for the two-sided chart the parameters \code{"k2"} and \code{"h2"} have to be set too.} \item{k2}{In case of a two-sided CUSUM chart for variance the reference value of the lower chart.} \item{h2}{In case of a two-sided CUSUM chart for variance the decision interval of the lower chart.} \item{hs2}{In case of a two-sided CUSUM chart for variance the headstart of the lower chart.} \item{r}{Dimension of the resulting linear equation system (highest order of the collocation polynomials times number of intervals -- see Knoth 2006).} \item{qm}{Number of quadrature nodes for calculating the collocation definite integrals.} \item{version}{Distinguish version numbers (1,2,...). For internal use only.} } \details{ \code{scusum.arl} determines the Average Run Length (ARL) by numerically solving the related ARL integral equation by means of collocation (piecewise Chebyshev polynomials).} \value{Returns a single value which resembles the ARL.} \references{ S. Knoth (2005), Accurate ARL computation for EWMA-\eqn{S^2}{S^2} control charts, \emph{Statistics and Computing 15}, 341-352. S. Knoth (2006), Computation of the ARL for CUSUM-\eqn{S^2}{S^2} schemes, \emph{Computational Statistics & Data Analysis 51}, 499-512. } \author{Sven Knoth} \seealso{ \code{xcusum.arl} for zero-state ARL computation of CUSUM control charts for monitoring normal mean. } \examples{ ## Knoth (2006) ## compare with Table 1 (p. 507) k <- 1.46 # sigma1 = 1.5 df <- 1 h <- 10 # original values # sigma coll63 BE Hawkins MC 10^9 (s.e.) # 1 260.7369 260.7546 261.32 260.7399 (0.0081) # 1.1 90.1319 90.1389 90.31 90.1319 (0.0027) # 1.2 43.6867 43.6897 43.75 43.6845 (0.0013) # 1.3 26.2916 26.2932 26.32 26.2929 (0.0007) # 1.4 18.1231 18.1239 18.14 18.1235 (0.0005) # 1.5 13.6268 13.6273 13.64 13.6272 (0.0003) # 2 5.9904 5.9910 5.99 5.9903 (0.0001) # replicate the column coll63 sigma <- c(1, 1.1, 1.2, 1.3, 1.4, 1.5, 2) arl <- rep(NA, length(sigma)) for ( i in 1:length(sigma) ) arl[i] <- round(scusum.arl(k, h, sigma[i], df, r=63, qm=20, version=2), digits=4) data.frame(sigma, arl) } \keyword{ts} spc/DESCRIPTION0000644000176200001440000000172114325502512012545 0ustar liggesusersPackage: spc Version: 0.6.7 Date: 2022-10-24 Title: Statistical Process Control -- Calculation of ARL and Other Control Chart Performance Measures 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 or variance of normally distributed independent data. ARL calculation of the same set of schemes under drift (in the mean) are added. Eventually, all ARL measures for the multivariate EWMA (MEWMA) are provided. License: GPL (>= 2) URL: https://www.r-project.org NeedsCompilation: yes Packaged: 2022-10-24 11:41:30 UTC; knoth Repository: CRAN Date/Publication: 2022-10-24 12:30:02 UTC spc/src/0000755000176200001440000000000014325474576011647 5ustar liggesusersspc/src/xsewma_res_pms.c0000644000176200001440000000120213553640534015031 0ustar liggesusers#include #include #include #include double xseU_mu_before_sigma_RES (double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double alpha, int vice_versa); void xsewma_res_pms ( double *alpha, int *n, int *ctyp, double *lx, double *cx, double *hsx, int *Nx, double *ls, double *csu, double *hss, int *Ns, double *mu, double *sigma, int *qm, int *vice_versa, double *pms) { *pms = -1.; *pms = xseU_mu_before_sigma_RES(*lx,*ls,*cx,*csu,*hsx,*hss,*mu,*sigma,*n,*Nx,*Ns,10000,*qm,*alpha,*vice_versa); } spc/src/tewma_arl_wowR.c0000644000176200001440000000106013553640534014770 0ustar liggesusers#include #include #include #include double tewma_arl(double lambda, int k, int lk, int uk, double z0, double mu); double tewma_arl_R(double lambda, int k, int lk, int uk, double gl, double gu, double z0, double mu); void tewma_arl_wowR (int *rando, double *lambda, int *k, int *lk, int *uk, double *gl, double *gu, double *z0, double *mu, double *arl) { *arl = -1.; if ( *rando==0 ) *arl = tewma_arl(*lambda, *k, *lk, *uk, *z0, *mu); if ( *rando==1 ) *arl = tewma_arl_R(*lambda, *k, *lk, *uk, *gl, *gu, *z0, *mu); } spc/src/ewma_p_arl_be.c0000644000176200001440000000171413553640534014561 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaL 1 #define ewma2 2 double ewma_pU_arl(double lambda, double ucl, int n, double p, double z0, int d_res, int round_mode, int mid_mode); double ewma_pL_arl(double lambda, double lcl, int n, double p, double z0, int d_res, int round_mode, int mid_mode); double ewma_p2_arl(double lambda, double lcl, double ucl, int n, double p, double z0, int d_res, int round_mode, int mid_mode); void ewma_p_arl_be (int *ctyp, double *lambda, double *lcl, double *ucl, int *n, double *p, double *z0, int *d_res, int *round_mode, int *mid_mode, double *arl) { *arl = -1.; if ( *ctyp==ewmaU ) *arl = ewma_pU_arl(*lambda, *ucl, *n, *p, *z0, *d_res, *round_mode, *mid_mode); if ( *ctyp==ewmaL ) *arl = ewma_pL_arl(*lambda, *lcl, *n, *p, *z0, *d_res, *round_mode, *mid_mode); if ( *ctyp==ewma2 ) *arl = ewma_p2_arl(*lambda, *lcl, *ucl, *n, *p, *z0, *d_res, *round_mode, *mid_mode); } spc/src/sewma_q_crit_prerun.c0000644000176200001440000000514313660005515016046 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 #define fixed 0 #define unbiased 1 double seU_q_crit_prerun_SIGMA(double l, int L0, double alpha, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double se2fu_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double s0, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); int se2_q_crit_prerun_SIGMA(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double seUR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double seLR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); void sewma_q_crit_prerun ( int *ctyp, int *ltyp, double *l, int *L0, double *alpha, double *cl0, double *cu0, double *hs, double *sigma, int *df1, int *r, int *qm1, int *df2, int *qm2, double *truncate, int *tail_approx, double *c_error, double *a_error, double *c_values) { int result=0; double cl=0., cu=1.; if ( *ctyp==ewmaU ) { cu = seU_q_crit_prerun_SIGMA(*l, *L0, *alpha, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate, *tail_approx, *c_error, *a_error); cl = 0.; } if ( *ctyp==ewmaUR ) { cu = seUR_q_crit_prerun_SIGMA(*l, *L0, *alpha, *cl0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate, *tail_approx, *c_error, *a_error); cl = *cl0; } if ( *ctyp==ewmaLR ) { cl = seLR_q_crit_prerun_SIGMA(*l, *L0, *alpha, *cu0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate, *tail_approx, *c_error, *a_error); cu = *cu0; } if ( *ctyp==ewma2 ) { if ( *ltyp==fixed ) { cl = se2fu_q_crit_prerun_SIGMA(*l, *L0, *alpha, *cu0, -1., *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate, *tail_approx, *c_error, *a_error); cu = *cu0; } if ( *ltyp==unbiased ) result = se2_q_crit_prerun_SIGMA(*l, *L0, *alpha, &cl, &cu, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate, *tail_approx, *c_error, *a_error); } if ( result != 0 ) warning("trouble with se2_crit called from sewma_q_crit_prerun [package spc]"); c_values[0] = cl; c_values[1] = cu; } spc/src/spc_init.c0000644000176200001440000003407014016161324013604 0ustar liggesusers#include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .C calls */ extern void ccusum_arl_be(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void ccusum_crit_be(void *, void *, void *, void *, void *, void *, void *, void *); extern void cewma_ad_be(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void cewma_arl_be(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void cewma_crit_be(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void euklid_ewma_arl(void *, void *, void *, void *, void *, void *, void *, void *); extern void ewma_p_arl_be(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void ewma_phat_arl_coll(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void ewma_phat_crit_coll(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void ewma_phat_lambda_coll(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void imr_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void lns2ewma_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void lns2ewma_crit(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void mewma_ad(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void mewma_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void mewma_arl_f(void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void mewma_crit(void *, void *, void *, void *, void *, void *); extern void mewma_psi(void *, void *, void *, void *, void *, void *, void *); extern void phat_cdf(void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void phat_pdf(void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void phat_qf(void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void quadrature_nodes_weights(void *, void *, void *, void *, void *); extern void s_res_ewma_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void scusum_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void scusum_crit(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void scusum_s_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void sewma_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void sewma_arl_prerun(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void sewma_crit(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void sewma_crit_prerun(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void sewma_q(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void sewma_q_crit(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void sewma_q_crit_prerun(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void sewma_q_prerun(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void sewma_sf(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void sewma_sf_prerun(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void tewma_arl_wowR(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void tol_lim_fac(void *, void *, void *, void *, void *, void *); extern void tshewhart_ar1_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void x_res_ewma_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xcusum_ad(void *, void *, void *, void *, void *, void *, void *); extern void xcusum_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xcusum_crit(void *, void *, void *, void *, void *, void *, void *); extern void xcusum_q(void *, void *, void *, void *, void *, void *, void *, void *); extern void xcusum_sf(void *, void *, void *, void *, void *, void *, void *, void *); extern void xDcusum_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xDewma_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xDgrsr_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xewma_ad(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xewma_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xewma_arl_f(void *, void *, void *, void *, void *, void *, void *, void *); extern void xewma_arl_prerun(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xewma_crit(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xewma_q(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xewma_q_prerun(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xewma_sf(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xewma_sf_prerun(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xgrsr_ad(void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xgrsr_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xgrsr_crit(void *, void *, void *, void *, void *, void *, void *, void *); extern void xsewma_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xsewma_crit(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xsewma_q(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xsewma_q_crit(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xsewma_res_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xsewma_res_pms(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xsewma_sf(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xshewhart_ar1_arl(void *, void *, void *, void *, void *, void *); extern void xtcusum_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xtewma_ad(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xtewma_arl(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xtewma_q(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void xtewma_sf(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); static const R_CMethodDef CEntries[] = { {"ccusum_arl_be", (DL_FUNC) &ccusum_arl_be, 14}, {"ccusum_crit_be", (DL_FUNC) &ccusum_crit_be, 8}, {"cewma_ad_be", (DL_FUNC) &cewma_ad_be, 12}, {"cewma_arl_be", (DL_FUNC) &cewma_arl_be, 13}, {"cewma_crit_be", (DL_FUNC) &cewma_crit_be, 12}, {"euklid_ewma_arl", (DL_FUNC) &euklid_ewma_arl, 8}, {"ewma_p_arl_be", (DL_FUNC) &ewma_p_arl_be, 11}, {"ewma_phat_arl_coll", (DL_FUNC) &ewma_phat_arl_coll, 13}, {"ewma_phat_crit_coll", (DL_FUNC) &ewma_phat_crit_coll, 12}, {"ewma_phat_lambda_coll", (DL_FUNC) &ewma_phat_lambda_coll, 12}, {"imr_arl", (DL_FUNC) &imr_arl, 9}, {"lns2ewma_arl", (DL_FUNC) &lns2ewma_arl, 9}, {"lns2ewma_crit", (DL_FUNC) &lns2ewma_crit, 11}, {"mewma_ad", (DL_FUNC) &mewma_ad, 12}, {"mewma_arl", (DL_FUNC) &mewma_arl, 10}, {"mewma_arl_f", (DL_FUNC) &mewma_arl_f, 9}, {"mewma_crit", (DL_FUNC) &mewma_crit, 6}, {"mewma_psi", (DL_FUNC) &mewma_psi, 7}, {"phat_cdf", (DL_FUNC) &phat_cdf, 9}, {"phat_pdf", (DL_FUNC) &phat_pdf, 9}, {"phat_qf", (DL_FUNC) &phat_qf, 9}, {"quadrature_nodes_weights", (DL_FUNC) &quadrature_nodes_weights, 5}, {"s_res_ewma_arl", (DL_FUNC) &s_res_ewma_arl, 11}, {"scusum_arl", (DL_FUNC) &scusum_arl, 13}, {"scusum_crit", (DL_FUNC) &scusum_crit, 12}, {"scusum_s_arl", (DL_FUNC) &scusum_s_arl, 14}, {"sewma_arl", (DL_FUNC) &sewma_arl, 11}, {"sewma_arl_prerun", (DL_FUNC) &sewma_arl_prerun, 13}, {"sewma_crit", (DL_FUNC) &sewma_crit, 14}, {"sewma_crit_prerun", (DL_FUNC) &sewma_crit_prerun, 18}, {"sewma_q", (DL_FUNC) &sewma_q, 11}, {"sewma_q_crit", (DL_FUNC) &sewma_q_crit, 16}, {"sewma_q_crit_prerun", (DL_FUNC) &sewma_q_crit_prerun, 19}, {"sewma_q_prerun", (DL_FUNC) &sewma_q_prerun, 14}, {"sewma_sf", (DL_FUNC) &sewma_sf, 11}, {"sewma_sf_prerun", (DL_FUNC) &sewma_sf_prerun, 14}, {"tewma_arl_wowR", (DL_FUNC) &tewma_arl_wowR, 10}, {"tol_lim_fac", (DL_FUNC) &tol_lim_fac, 6}, {"tshewhart_ar1_arl", (DL_FUNC) &tshewhart_ar1_arl, 10}, {"x_res_ewma_arl", (DL_FUNC) &x_res_ewma_arl, 9}, {"xcusum_ad", (DL_FUNC) &xcusum_ad, 7}, {"xcusum_arl", (DL_FUNC) &xcusum_arl, 9}, {"xcusum_crit", (DL_FUNC) &xcusum_crit, 7}, {"xcusum_q", (DL_FUNC) &xcusum_q, 8}, {"xcusum_sf", (DL_FUNC) &xcusum_sf, 8}, {"xDcusum_arl", (DL_FUNC) &xDcusum_arl, 11}, {"xDewma_arl", (DL_FUNC) &xDewma_arl, 13}, {"xDgrsr_arl", (DL_FUNC) &xDgrsr_arl, 11}, {"xewma_ad", (DL_FUNC) &xewma_ad, 11}, {"xewma_arl", (DL_FUNC) &xewma_arl, 11}, {"xewma_arl_f", (DL_FUNC) &xewma_arl_f, 8}, {"xewma_arl_prerun", (DL_FUNC) &xewma_arl_prerun, 15}, {"xewma_crit", (DL_FUNC) &xewma_crit, 10}, {"xewma_q", (DL_FUNC) &xewma_q, 11}, {"xewma_q_prerun", (DL_FUNC) &xewma_q_prerun, 17}, {"xewma_sf", (DL_FUNC) &xewma_sf, 11}, {"xewma_sf_prerun", (DL_FUNC) &xewma_sf_prerun, 18}, {"xgrsr_ad", (DL_FUNC) &xgrsr_ad, 9}, {"xgrsr_arl", (DL_FUNC) &xgrsr_arl, 10}, {"xgrsr_crit", (DL_FUNC) &xgrsr_crit, 8}, {"xsewma_arl", (DL_FUNC) &xsewma_arl, 16}, {"xsewma_crit", (DL_FUNC) &xsewma_crit, 15}, {"xsewma_q", (DL_FUNC) &xsewma_q, 16}, {"xsewma_q_crit", (DL_FUNC) &xsewma_q_crit, 18}, {"xsewma_res_arl", (DL_FUNC) &xsewma_res_arl, 15}, {"xsewma_res_pms", (DL_FUNC) &xsewma_res_pms, 16}, {"xsewma_sf", (DL_FUNC) &xsewma_sf, 16}, {"xshewhart_ar1_arl", (DL_FUNC) &xshewhart_ar1_arl, 6}, {"xtcusum_arl", (DL_FUNC) &xtcusum_arl, 9}, {"xtewma_ad", (DL_FUNC) &xtewma_ad, 13}, {"xtewma_arl", (DL_FUNC) &xtewma_arl, 12}, {"xtewma_q", (DL_FUNC) &xtewma_q, 13}, {"xtewma_sf", (DL_FUNC) &xtewma_sf, 13}, {NULL, NULL, 0} }; void R_init_spc(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } spc/src/xcusum_sf.c0000644000176200001440000000106613553640534014021 0ustar liggesusers#include #include #include #include #define cusum1 0 #define cusum2 1 double *vector (long n); double xc1_sf(double k, double h, double hs, double mu, int N, int nmax, double *p0); void xcusum_sf(int *ctyp, double *k, double *h, double *hs, double *mu, int *r, int *n, double *sf) { int result=0, i; double *p0; p0 = vector(*n); if (*ctyp==cusum1) result = xc1_sf(*k, *h, *hs, *mu, *r, *n, p0); if ( result != 0 ) warning("trouble with xc1_sf called from xcusum_sf [package spc]"); for (i=0; i<*n; i++) sf[i] = p0[i]; } spc/src/xDgrsr_arl.c0000644000176200001440000000163213553640534014113 0ustar liggesusers#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/imr_arl.c0000644000176200001440000000157714017134024013425 0ustar liggesusers#include #include #include #include #define upper 0 #define two 1 double imr_arl_case01(double M, double R, double mu, double sigma, int N, int qm); double imr_arl_case02(double M, double R, double mu, double sigma, int N, int qm); double imr2_arl(double M, double Rl, double Ru, double mu, double sigma, int N, int qm); double imr2_arl_case03(double M, double Rl, double mu, double sigma, int N, int qm); void imr_arl (double *M, double *Rl, double *Ru, double *mu, double *sigma, int *vtyp, int *N, int *qm, double *arl) { *arl = -1.; if ( *vtyp == upper ) { if ( *Ru >= *M ) *arl = imr_arl_case01(*M, *Ru, *mu, *sigma, *N, *qm); else *arl = imr_arl_case02(*M, *Ru, *mu, *sigma, *N, *qm); } else { if ( *Ru >= *M * 2. ) *arl = imr2_arl_case03(*M, *Rl, *mu, *sigma, *N, *qm); else *arl = imr2_arl(*M, *Rl, *Ru, *mu, *sigma, *N, *qm); } } spc/src/sewma_crit_prerun.c0000644000176200001440000000405213553640534015533 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 #define fixed 0 #define unbiased 1 double seU_crit_prerun_SIGMA(double l, double L0, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double se2fu_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); int se2_crit_prerun_SIGMA(double l, double L0, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seUR_crit_prerun_SIGMA(double l, double L0, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seLR_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); void sewma_crit_prerun ( int *ctyp, int *ltyp, double *l, int *L0, double *cl0, double *cu0, double *hs, double *sigma, int *df1, int *r, int *qm1, int *df2, int *qm2, double *truncate, int *tail_approx, double *c_error, double *a_error, double *c_values) { int result=0; double cl=0., cu=1.; if ( *ctyp==ewmaU ) { cu = seU_crit_prerun_SIGMA(*l, *L0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate); cl = 0.; } if ( *ctyp==ewmaUR ) { cu = seUR_crit_prerun_SIGMA(*l, *L0, *cl0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate); cl = *cl0; } if ( *ctyp==ewmaLR ) { cl = seLR_crit_prerun_SIGMA(*l, *L0, *cu0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate); cu = *cu0; } if ( *ctyp==ewma2 ) { if ( *ltyp==fixed ) { cl = se2fu_crit_prerun_SIGMA(*l, *L0, *cu0, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate); cu = *cu0; } if ( *ltyp==unbiased ) result = se2_crit_prerun_SIGMA(*l, *L0, &cl, &cu, *hs, *sigma, *df1, *df2, *r, *qm1, *qm2, *truncate); } if ( result != 0 ) warning("trouble with se2_crit_prerun_SIGMA called from sewma_crit_prerun [package spc]"); c_values[0] = cl; c_values[1] = cu; } spc/src/ccusum_arl_be.c0000644000176200001440000000263513553640534014613 0ustar liggesusers#include #include #include #include #define cusumU 0 #define cusumL 1 #define cusum2 2 double ccusum_U_arl(double mu, int km, int hm, int m, int i0); double ccusum_U_arl_rando(double mu, int km, int hm, int m, double gamma, int i0); double ccusum_L_arl(double mu, int km, int hm, int m, int i0); double ccusum_L_arl_rando(double mu, int km, int hm, int m, double gamma, int i0); double ccusum_2_arl(double mu, int km1, int hm1, int m1, int i01, int km2, int hm2, int m2, int i02); double ccusum_2_arl_rando(double mu, int km1, int hm1, int m1, double gamma1, int i01, int km2, int hm2, int m2, double gamma2, int i02); void ccusum_arl_be (int *ctyp, int *rando, double *mu, int *km, int *hm, int *m, int *i0, double *gamma, int *km2, int *hm2, int *m2, int *i02, double *gamma2, double *arl) { *arl = -1.; if ( *ctyp==cusumU && *rando==0 ) *arl = ccusum_U_arl(*mu, *km, *hm, *m, *i0); if ( *ctyp==cusumU && *rando==1 ) *arl = ccusum_U_arl_rando(*mu, *km, *hm, *m, *gamma, *i0); if ( *ctyp==cusumL && *rando==0 ) *arl = ccusum_L_arl(*mu, *km, *hm, *m, *i0); if ( *ctyp==cusumL && *rando==1 ) *arl = ccusum_L_arl_rando(*mu, *km, *hm, *m, *gamma, *i0); if ( *ctyp==cusum2 && *rando==0 ) *arl = ccusum_2_arl(*mu, *km, *hm, *m, *i0, *km2, *hm2, *m2, *i02); if ( *ctyp==cusum2 && *rando==1 ) *arl = ccusum_2_arl_rando(*mu, *km, *hm, *m, *gamma, *i0, *km2, *hm2, *m2, *gamma2, *i02); } spc/src/ewma_phat_arl_coll.c0000644000176200001440000000235113553640534015617 0ustar liggesusers#include #include #include #include double ewma_phat_arl(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm); double ewma_phat_arl_be(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N); double ewma_phat_arl2(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M); double ewma_phat_arl2_be(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N); void ewma_phat_arl_coll (double *lambda, double *ucl, double *mu, double *sigma, int *n, double *z0, int *ctyp, double *LSL, double *USL, int *N, int *qm, int *ntyp, double *arl) { int M=4; *arl = -1.; if ( *ctyp == 0 ) { if ( *ntyp == 0 ) *arl = ewma_phat_arl(*lambda, *ucl, *mu, *sigma, *n, *z0, *LSL, *USL, *N, *qm); if ( *ntyp == 1 ) *arl = ewma_phat_arl_be(*lambda, *ucl, *mu, *sigma, *n, *z0, *LSL, *USL, *N); } if ( *ctyp == 1 ) { if ( *ntyp == 0 ) *arl = ewma_phat_arl2(*lambda, *ucl, *mu, *sigma, *n, *z0, *LSL, *USL, *N, *qm, M); if ( *ntyp == 1 ) *arl = ewma_phat_arl2_be(*lambda, *ucl, *mu, *sigma, *n, *z0, *LSL, *USL, *N); } } spc/src/mewma_ad.c0000644000176200001440000000210113553640534013546 0ustar liggesusers#include #include #include #include #define GL 0 #define CO 1 #define RA 2 #define CC 3 #define MC 4 #define SR 5 #define CO2 6 #define GL2 7 #define GL3 8 #define GL4 9 #define GL5 10 #define CO3 11 #define CO4 12 #define nGL1 13 #define nGL2 14 #define nGL3 15 #define nGL4 16 #define nGL5 17 double mxewma_ad (double lambda, double ce, int p, double delta, int N, int qm2, int psi_type, double hs, int qtype, int qm0, int qm1); double mxewma_ad_new(double lambda, double ce, int p, double delta, int N, int psi_type, double hs, int qtype); double mxewma_ad_e(double lambda, double ce, int p, double delta, int psi_type, int N); void mewma_ad(double *l, double *c, int *p, double *delta, int *r, int *qm2, int *ptype, double *hs, int *qtype, int *qm0, int *qm1, double *ad) { if ( *qtype == MC ) *ad = mxewma_ad_e(*l, *c, *p, *delta, *ptype, *r); else { if ( *qtype < nGL1 ) *ad = mxewma_ad(*l, *c, *p, *delta, *r, *qm2, *ptype, *hs, *qtype, *qm0, *qm1); else *ad = mxewma_ad_new(*l, *c, *p, *delta, *r, *ptype, *hs, *qtype); } } spc/src/sewma_crit.c0000644000176200001440000000663313553640534014147 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 #define fixed 0 #define unbiased 1 #define eqtails 2 #define sym 3 double seU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm); double seUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm); double seLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); double se2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); int se2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm); int se2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm); double se2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm); double stdeU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm); double stdeUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm); double stdeLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); double stde2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); int stde2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm); int stde2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm); double stde2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm); double c_four(double ddf); void sewma_crit ( int *ctyp, int *ltyp, double *l, double *L0, double *cl0, double *cu0, double *hs, double *sigma, int *df, int *r, int *qm, double *ur, int *s_squared, double *c_values) { int result=0; double cl=0., cu=1., mitte=1.; if ( *s_squared==1 ) { if (*ctyp==ewmaU) cu = seU_crit(*l,*L0,*hs,*sigma,*df,*r,*qm); if (*ctyp==ewmaUR) { cu = seUR_crit(*l,*L0,*cl0,*hs,*sigma,*df,*r,*qm); cl = *cl0; } if (*ctyp==ewmaLR) { cl = seLR_crit(*l,*L0,*cu0,*hs,*sigma,*df,*r,*qm); cu = *cu0; } if (*ctyp==ewma2) { if (*ltyp==fixed) { cl = se2fu_crit(*l,*L0,*cu0,*hs,*sigma,*df,*r,*qm); cu = *cu0; } if (*ltyp==unbiased) result = se2_crit_unbiased(*l, *L0, &cl, &cu, *hs, *sigma, *df, *r, *qm); if (*ltyp==eqtails) result = se2_crit_eqtails(*l, *L0, &cl, &cu, *hs, *sigma, *df, *ur, *r, *qm); if (*ltyp==sym) { cu = se2_crit_sym(*l, *L0, *hs, *sigma, *df, *r, *qm); cl = 2. - cu; } } } else { mitte = c_four((double)*df); if ( *ctyp==ewmaU ) cu = stdeU_crit(*l,*L0,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewmaUR ) { cu = stdeUR_crit(*l,*L0,*cl0,*hs,*sigma,*df,*r,*qm); cl = *cl0; } if ( *ctyp==ewmaLR ) { cl = stdeLR_crit(*l,*L0,*cu0,*hs,*sigma,*df,*r,*qm); cu = *cu0; } if ( *ctyp==ewma2 ) { if ( *ltyp==fixed ) { cl = stde2fu_crit(*l,*L0,*cu0,*hs,*sigma,*df,*r,*qm); cu = *cu0; } if ( *ltyp==unbiased ) result = stde2_crit_unbiased(*l, *L0, &cl, &cu, *hs, *sigma, *df, *r, *qm); if ( *ltyp==eqtails ) result = stde2_crit_eqtails(*l, *L0, &cl, &cu, *hs, *sigma, *df, *ur, *r, *qm); if ( *ltyp==sym ) { cu = stde2_crit_sym(*l, *L0, *hs, *sigma, *df, *r, *qm); cl = 2.*mitte - cu; } } } if ( result != 0 ) warning("trouble with se2_crit called from sewma_crit [package spc]"); c_values[0] = cl; c_values[1] = cu; } spc/src/xcusum_crit.c0000644000176200001440000000047013553640534014350 0ustar liggesusers#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/lns2ewma_crit.c0000644000176200001440000000315713553640534014561 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaL 1 #define ewma2 2 #define fixed 0 #define unbiased 1 #define eqtails 2 #define sym 3 double lns2ewmaU_crit(double l, double L0, double cl, double hs, double sigma, int df, int N); double lns2ewma2_crit_cufix(double l, double cu, double L0, double hs, double sigma, int df, int N); double lns2ewma2_crit_sym(double l, double L0, double hs, double sigma, int df, int N); int lns2ewma2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N); void lns2ewma_crit ( int *ctyp, int *ltyp, double *l, double *L0, double *cl0, double *cu0, double *hs, double *sigma, int *df, int *r, double *c_values) { int result=0; double cl=0., cu=1., ddf=1., mitte=0.; ddf = (double)*df; mitte = -1./ddf - 1./3./ddf/ddf + 2./15./ddf/ddf/ddf/ddf; if ( *ctyp==ewmaU ) cu = lns2ewmaU_crit(*l, *L0, *cl0, *hs, *sigma, *df, *r); /*if ( *ctyp==ewmaL ) cl = lns2ewmaL_crit(*l, *L0, *cu0, *hs, *sigma, *df, *r);*/ if ( *ctyp==ewma2 ) { if (*ltyp==fixed) { cl = lns2ewma2_crit_cufix(*l, *cu0, *L0, *hs, *sigma, *df, *r); cu = *cu0; } if ( *ltyp==unbiased ) result = lns2ewma2_crit_unbiased(*l, *L0, &cl, &cu, *hs, *sigma, *df, *r); /*if ( *ltyp==eqtails ) result = lns2ewma2_crit_eqtails(*l, *L0, &cl, &cu, *hs, *sigma, *df, *r);*/ if ( *ltyp==sym ) { cl = lns2ewma2_crit_sym(*l, *L0, *hs, *sigma, *df, *r); cu = 2*mitte - cl; } } if ( result != 0 ) warning("trouble with lns2ewma2_crit_unbiased called from lns2ewma_crit [package spc]"); c_values[0] = cl; c_values[1] = cu; } spc/src/sewma_res_arl.c0000644000176200001440000000064513553640534014632 0ustar liggesusers#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/sewma_arl_prerun.c0000644000176200001440000000260013553640534015345 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 double seU_iglarl_prerun_SIGMA(double l, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seUR_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double se2_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seLR_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); void sewma_arl_prerun ( int *ctyp, double *l, double *cl, double *cu, double *hs, double *sigma, int *df1, int *N, int *qm1, int *df2, int *qm2, double *truncate, double *arl) { *arl = -1.; if ( *ctyp==ewmaU ) *arl = seU_iglarl_prerun_SIGMA(*l, *cu, *hs, *sigma, *df1, *df2, *N, *qm1, *qm2, *truncate); if ( *ctyp==ewma2 ) *arl = se2_iglarl_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *N, *qm1, *qm2, *truncate); if ( *ctyp==ewmaUR ) *arl = seUR_iglarl_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *N, *qm1, *qm2, *truncate); if ( *ctyp==ewmaLR ) *arl = seLR_iglarl_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *N, *qm1, *qm2, *truncate); } spc/src/quadrature_nodes_weights.c0000644000176200001440000000130613553640534017101 0ustar liggesusers#include #include #include #include #define GL 0 #define Ra 1 double *vector (long n); void gausslegendre(int n, double x1, double x2, double *x, double *w); void radau(int n, double x1, double x2, double *x, double *w); void quadrature_nodes_weights(int *n, double *x1, double *x2, int *type, double *nodes_weights) { double *knoten, *gewichte; int i; knoten = vector(*n); gewichte = vector(*n); if ( *type==GL ) gausslegendre(*n, *x1, *x2, knoten, gewichte); if ( *type==Ra ) radau(*n, *x1, *x2, knoten, gewichte); for (i=0; i<*n; i++) { nodes_weights[i] = knoten[i]; nodes_weights[i+*n] = gewichte[i]; } Free(gewichte); Free(knoten); } spc/src/euklid_ewma_arl.c0000644000176200001440000000051213553640534015124 0ustar liggesusers#include #include #include #include double eewma_arl(int gX, int gY, int kL, int kU, double mu, double y0, int r0); void euklid_ewma_arl (int *gX, int *gY, int *kL, int *kU, double *mu, double *y0, int *r0, double *arl) { *arl = -1.; *arl = eewma_arl(*gX, *gY, *kL, *kU, *mu, *y0, *r0); } spc/src/ccusum_crit_be.c0000644000176200001440000000211413660226302014756 0ustar liggesusers#include #include #include #include #define cusumU 0 #define cusumL 1 #define cusum2 2 int ccusum_U_crit(double A, double mu0, int km, int m, int i0); int ccusum_U_rando_crit(double A, double mu0, int km, int m, int i0, int *hm, double *gamma); int ccusum_L_crit(double A, double mu0, int km, int m, int i0); int ccusum_L_rando_crit(double A, double mu0, int km, int m, int i0, int *hm, double *gamma); void ccusum_crit_be (int *ctyp, int *rando, double *mu0, int *km, double *A, int *m, int *i0, double *c_values) { double gamma=0.; int result=0, hm=0; if ( *ctyp==cusumU && *rando==0 ) hm = ccusum_U_crit(*A, *mu0, *km, *m, *i0); if ( *ctyp==cusumU && *rando==1 ) result = ccusum_U_rando_crit(*A, *mu0, *km, *m, *i0, &hm, &gamma); if ( *ctyp==cusumL && *rando==0 ) hm = ccusum_L_crit(*A, *mu0, *km, *m, *i0); if ( *ctyp==cusumL && *rando==1 ) result = ccusum_L_rando_crit(*A, *mu0, *km, *m, *i0, &hm, &gamma); if ( result != 0 ) warning("something went wrong with ccusum_*_rando_crit"); c_values[0] = (double)hm; c_values[1] = gamma; } spc/src/xewma_ad.c0000644000176200001440000000530014277701276013572 0ustar liggesusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define stat 5 #define fink 6 #define conditional 0 #define cyclical 1 extern double rho0; double xe1_iglad(double l, double c, double zr, double mu0, double mu1, int N); double xe1_arlm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); double xe2_iglad (double l, double c, double mu0, double mu1, int N); double xe2_igladc(double l, double c, double mu0, double mu1, double z0, int N); double xe2_arlm (double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); double xe2_arlmc(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); void xewma_ad(int *ctyp, double *l, double *c, double *zr, double *mu0, double *mu1, double *z0, int *ltyp, int *styp, int *r, double *ad) { int nmax=1000000, q2=200; double ad1=1., ad2=1., eps=.0001; if ( *styp==conditional ) { if ( *ctyp==ewma1 && *ltyp==fix ) *ad = xe1_iglad(*l,*c,*zr,*mu0,*mu1,*r); if ( *ctyp==ewma1 && *ltyp>fix ) { ad1 = xe1_arlm(*l,*c,*zr,0.,200,*mu0,*mu1,*ltyp,*r,nmax); ad2 = xe1_arlm(*l,*c,*zr,0.,300,*mu0,*mu1,*ltyp,*r,nmax); if ( fabs(ad1-ad2) > eps ) { q2 = 300; while ( fabs(ad1-ad2) > eps ) { ad1 = ad2; q2 += 100; ad2 = xe1_arlm(*l,*c,*zr,0.,q2,*mu0,*mu1,*ltyp,*r,nmax); } } *ad = ad2; } if ( *ctyp==ewma2 && *ltyp==fix ) *ad = xe2_iglad(*l,*c,*mu0,*mu1,*r); if ( *ctyp==ewma2 && *ltyp>fix ) { ad1 = xe2_arlm(*l,*c,0.,200,*mu0,*mu1,*ltyp,*r,nmax); /*printf("q = 200,\tad = %.5f\n", ad1);*/ ad2 = xe2_arlm(*l,*c,0.,300,*mu0,*mu1,*ltyp,*r,nmax); /*printf("q = 300,\tad = %.5f\n", ad2);*/ if ( fabs(ad1-ad2) > eps ) { /*printf("\nTuning needed\n\n");*/ q2 = 300; while ( fabs(ad1-ad2) > eps ) { ad1 = ad2; q2 += 100; ad2 = xe2_arlm(*l,*c,0.,q2,*mu0,*mu1,*ltyp,*r,nmax); /*printf("q = %d,\tad = %.5f\n", q2, ad2);*/ } /*printf("\n");*/ } *ad = ad2; } } else { if ( *ctyp==ewma2 && *ltyp==fix ) *ad = xe2_igladc(*l, *c, *mu0, *mu1, *z0, *r); if ( *ctyp==ewma2 && *ltyp>fix ) { ad1 = xe2_arlmc(*l,*c,0.,200,*mu0,*mu1,*ltyp,*r,nmax); ad2 = xe2_arlmc(*l,*c,0.,300,*mu0,*mu1,*ltyp,*r,nmax); if ( fabs(ad1-ad2) > eps ) { q2 = 300; while ( fabs(ad1-ad2) > eps ) { ad1 = ad2; q2 += 100; ad2 = xe2_arlmc(*l,*c,0.,q2,*mu0,*mu1,*ltyp,*r,nmax); } } *ad = ad2; } } } spc/src/xtewma_ad.c0000644000176200001440000000240313553640534013752 0ustar liggesusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define conditional 0 #define cyclical 1 extern double rho0; /* double xe2_iglad (double l, double c, double mu0, double mu1, int N); double xe2_igladc(double l, double c, double mu0, double mu1, double z0, int N); double xe2_arlm (double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax);*/ double xte2_iglad(double l, double c, int df, double mu0, double mu1, int N, int subst); double xte2_igladc(double l, double c, int df, double mu0, double mu1, double z0, int N, int subst); double xte2_arlm (double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst); void xtewma_ad(int *ctyp, double *l, double *c, double *zr, int *df, double *mu0, double *mu1, double *z0, int *ltyp, int *styp, int *r, int *ntyp, double *ad) { int nmax=1000000; if ( *styp==conditional ) { if ( *ctyp==ewma2 && *ltyp==fix ) *ad = xte2_iglad(*l,*c,*df,*mu0,*mu1,*r,*ntyp); if ( *ctyp==ewma2 && *ltyp>fix ) *ad = xte2_arlm(*l,*c,0.,*df,200,*mu0,*mu1,*ltyp,*r,nmax,*ntyp); } else { if ( *ctyp==ewma2 && *ltyp==fix ) *ad = xte2_igladc(*l,*c,*df,*mu0,*mu1,*z0,*r,*ntyp); } } spc/src/cewma_ad_be.c0000644000176200001440000000141013651512707014203 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaL 1 #define ewma2 2 #define classic 0 #define transfer 1 double cewma_2_ad(double lambda, double AL, double AU, double mu0, double mu, int N); double cewma_2_ad_new(double lambda, double AL, double AU, double mu0, double mu, int N); void cewma_ad_be (int *ctyp, int *mcdesign, int *rando, double *lambda, double *AL, double *AU, double *gL, double *gU, double *mu0, double *mu, int *N, double *ad) { *ad = -1.; if ( *ctyp==ewma2 && *mcdesign==classic ) { if ( *rando==0 ) *ad = cewma_2_ad(*lambda, *AL, *AU, *mu0, *mu, *N); } if ( *ctyp==ewma2 && *mcdesign==transfer ) { if ( *rando==0 ) *ad = cewma_2_ad_new(*lambda, *AL, *AU, *mu0, *mu, *N); } } spc/src/xcusum_arl.c0000644000176200001440000000422413553640534014166 0ustar liggesusers#include #include #include #include #define cusum1 0 #define cusum2 1 #define cusumC 2 #define igl 0 #define mc 1 #define mcT 2 #define mcL 3 extern double rho0; double *vector (long n); double xc1_iglarl(double k, double h, double hs, double mu, int N); double xc1_be_arl(double k, double h, double hs, double mu, int N); double xc1_beL_arl(double k, double h, double hs, double mu, int N); double xc1_beT_arl(double k, double h, double hs, double mu, int N); double xc1_arlm(double k, double h, double hs, int q, double mu0, double mu1, int N, int nmax); double xc1_arlm_hom(double k, double h, double hs, int q, double mu0, double mu1, int N, double *ced); double xc2_iglarl(double k, double h, double hs, double mu, int N); double xc2_be_arl(double k, double h, double hs1, double hs2, double mu, int N); double xcC_iglarl(double k, double h, double hs, double mu, int N); double xc2_be_arlm(double k, double h, double hs1, double hs2, int q, double mu0, double mu1, int N, double *ced); void xcusum_arl ( int *ctyp, double *k, double *h, double *hs, double *mu, int *q, int *r, int *method, double *arl) { int i, /*nmax=100000,*/ result=0; double lhs, *ced, arl1=-1.; ced = vector(*q); if ( *ctyp == cusum1 && *q==1 ) { if ( *method == igl ) arl1 = xc1_iglarl(*k,*h,*hs,*mu,*r); if ( *method == mc ) arl1 = xc1_be_arl(*k,*h,*hs,*mu,*r); if ( *method == mcT ) arl1 = xc1_beT_arl(*k,*h,*hs,*mu,*r); if ( *method == mcL ) arl1 = xc1_beL_arl(*k,*h,*hs,*mu,*r); } if ( *ctyp == cusum1 && *q>1 ) result = xc1_arlm_hom(*k, *h, *hs, *q, 0., *mu, *r, ced); /* *arl = xc1_arlm(*k, *h, *hs, *q, 0., *mu, *r, nmax); */ if ( *ctyp == cusum2 && *q==1 ) { if ( *method == igl ) arl1 = xc2_iglarl(*k,*h,*hs,*mu,*r); lhs = - *hs; if ( *method == mc ) arl1 = xc2_be_arl(*k,*h,*hs,lhs,*mu,*r); } if ( *ctyp == cusum2 && *q>1 ) { lhs = - *hs; result = xc2_be_arlm(*k, *h, *hs, lhs, *q, 0., *mu, *r, ced); } if ( *ctyp == cusumC ) arl1 = xcC_iglarl(*k,*h,*hs,*mu,*r); if ( result != 0 ) warning("trouble in xcusum_arl [package spc]"); if ( *q > 1 ) for (i=0; i<*q; i++) arl[i] = ced[i]; else *arl = arl1; } spc/src/sewma_arl.c0000644000176200001440000000332213553640534013754 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 double seU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm); double se2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double seUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double seLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double stdeU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm); double stde2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double stdeUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double stdeLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); void sewma_arl ( int *ctyp, double *l, double *cl, double *cu, double *hs, double *sigma, int *df, int *r, int *qm, int *s_squared, double *arl) { *arl = -1.; if ( *s_squared==1 ) { if ( *ctyp==ewmaU ) *arl = seU_iglarl(*l,*cu,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewma2 ) *arl = se2_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewmaUR ) *arl = seUR_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewmaLR ) *arl = seLR_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm); } else { if ( *ctyp==ewmaU ) *arl = stdeU_iglarl(*l,*cu,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewma2 ) *arl = stde2_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewmaUR ) *arl = stdeUR_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm); if ( *ctyp==ewmaLR ) *arl = stdeLR_iglarl(*l,*cl,*cu,*hs,*sigma,*df,*r,*qm); } } spc/src/xewma_crit.c0000644000176200001440000000061013553640534014141 0ustar liggesusers#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/sewma_sf.c0000644000176200001440000000245613553640534013615 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 double *vector (long n); double seU_sf(double l, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); double se2_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); double seUR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); double seLR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); void sewma_sf ( int *ctyp, double *l, double *cl, double *cu, double *hs, int *N, double *sigma, int *df, int *qm, int *n, double *sf) { int result=0, i; double *p0; p0 = vector(*n); if ( *ctyp == ewmaU ) result = seU_sf(*l, *cu, *hs, *sigma, *df, *N, *n, *qm, p0); if ( *ctyp == ewmaUR ) result = seUR_sf(*l, *cl, *cu, *hs, *sigma, *df, *N, *n, *qm, p0); if ( *ctyp == ewma2 ) result = se2_sf(*l, *cl, *cu, *hs, *sigma, *df, *N, *n, *qm, p0); if ( *ctyp == ewmaLR ) result = seLR_sf(*l, *cl, *cu, *hs, *sigma, *df, *N, *n, *qm, p0); if ( result != 0 ) warning("trouble in sewma_sf [package spc]"); for (i=0; i<*n; i++) sf[i] = p0[i]; Free(p0); } spc/src/sewma_q_crit.c0000644000176200001440000000455113553640534014464 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 #define fixed 0 #define unbiased 1 #define classic 2 double seU_q_crit(double l, int L0, double alpha, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); /*double se2lu_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error);*/ double se2fu_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); int se2_q_crit(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); int se2_q_crit_class(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm, double c_error, double a_error); double seUR_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); double seLR_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); void sewma_q_crit ( int *ctyp, int *ltyp, double *l, int *L0, double *alpha, double *cl0, double *cu0, double *hs, double *sigma, int *df, int *r, int *qm, double *ur, double *c_error, double *a_error, double *c_values) { int result=0; double cl=0., cu=1.; if ( *ctyp==ewmaU ) { cu = seU_q_crit(*l, *L0, *alpha, *hs, *sigma, *df, *r, *qm, *c_error, *a_error); cl = 0.; } if ( *ctyp==ewmaUR ) { cu = seUR_q_crit(*l, *L0, *alpha, *cl0, *hs, *sigma, *df, *r, *qm, *c_error, *a_error); cl = *cl0; } if ( *ctyp==ewmaLR ) { cl = seLR_q_crit(*l, *L0, *alpha, *cu0, *hs, *sigma, *df, *r, *qm, *c_error, *a_error); cu = *cu0; } if ( *ctyp==ewma2 ) { if ( *ltyp==fixed ) { cl = se2fu_q_crit(*l, *L0, *alpha, *cu0, *hs, *sigma, *df, *r, *qm, *c_error, *a_error); cu = *cu0; } if ( *ltyp==unbiased ) result = se2_q_crit(*l, *L0, *alpha, &cl, &cu, *hs, *sigma, *df, *r, *qm, *c_error, *a_error); if ( *ltyp==classic ) result = se2_q_crit_class(*l, *L0, *alpha, &cl, &cu, *hs, *sigma, *df, *ur, *r, *qm, *c_error, *a_error); } if ( result != 0 ) warning("trouble with se2_crit called from sewma_q_crit [package spc]"); c_values[0] = cl; c_values[1] = cu; } spc/src/mewma_crit.c0000644000176200001440000000041513553640534014131 0ustar liggesusers#include #include #include #include double mxewma_crit(double lambda, double L0, int p, double hs, int N); void mewma_crit(double *l, double *L0, int *p, double *hs, int *r, double *h) { *h = mxewma_crit(*l, *L0, *p, *hs, *r); } spc/src/xewma_q_prerun.c0000644000176200001440000000557413553640534015051 0ustar liggesusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define stat 5 #define MU 0 #define SIGMA 1 #define BOTH 2 double xe2_Wq_prerun_MU_deluxe(double l, double c, double p, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND); double xe2_Wq_prerun_SIGMA_deluxe(double l, double c, double p, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND); double xe2_Wq_prerun_BOTH_deluxe(double l, double c, double p, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double BOUND); double xe2_Wqm_prerun_MU_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND); double xe2_Wqm_prerun_SIGMA_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND); double xe2_Wqm_prerun_BOTH_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double BOUND); void xewma_q_prerun ( int *ctyp, double *l, double *c, double *p, double *zr, double *hs, double *mu, int *ltyp, int *q, int *size, int *df, int *mode, int *qm1, int *qm2, double *truncate, double *bound, double *tq) { int nmax=1000000; if ( *mode == MU ) { if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xe2_Wq_prerun_MU_deluxe(*l, *c, *p, *hs, *mu, *size, nmax, *qm1, *truncate, *bound); if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xe2_Wqm_prerun_MU_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm1, *truncate, *bound); if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xe2_Wqm_prerun_MU_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm1, *truncate, *bound); } if ( *mode == SIGMA ) { if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xe2_Wq_prerun_SIGMA_deluxe(*l, *c, *p, *hs, *mu, *size, nmax, *qm2, *truncate, *bound); if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xe2_Wqm_prerun_SIGMA_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm2, *truncate, *bound); if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xe2_Wqm_prerun_SIGMA_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm2, *truncate, *bound); } if ( *mode == BOTH ) { if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xe2_Wq_prerun_BOTH_deluxe(*l, *c, *p, *hs, *mu, *size, *df, nmax, *qm1, *qm2, *truncate, *bound); if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xe2_Wqm_prerun_BOTH_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *df, *ltyp, nmax, *qm1, *qm2, *truncate, *bound); if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xe2_Wqm_prerun_BOTH_deluxe(*l, *c, *p, *hs, *q, 0., *mu, *size, *df, *ltyp, nmax, *qm1, *qm2, *truncate, *bound); } } spc/src/tol_lim_fac.c0000644000176200001440000000055613553640534014260 0ustar liggesusers#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/phat_cdf.c0000644000176200001440000000103413553640534013550 0ustar liggesusers#include #include #include #include double cdf_phat(double p, double mu, double sigma, int n, double LSL, double USL); double cdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes); void phat_cdf (double *x, int *n, double *mu, double *sigma, int *ctyp, double *LSL, double *USL, int *nodes, double *cdf) { *cdf = -1.; if ( *ctyp == 0 ) *cdf = cdf_phat(*x, *mu, *sigma, *n, *LSL, *USL); if ( *ctyp == 1 ) *cdf = cdf_phat2(*x, *mu, *sigma, *n, *LSL, *USL, *nodes); } spc/src/mewma_psi.c0000644000176200001440000000150313553640534013762 0ustar liggesusers#include #include #include #include #define cond 0 #define cycl 1 double *vector (long n); double mxewma_psi (double lambda, double ce, int p, int N, double *PSI, double *w, double *z); double mxewma_psiS(double lambda, double ce, int p, double hs, int N, double *PSI, double *w, double *z); void mewma_psi(double *l, double *c, int *p, int *type, double *hs, int *r, double *zeug) { double *PSI, *w, *z, zahl=0.; int i; PSI = vector(*r); w = vector(*r); z = vector(*r); if ( *type == cond ) zahl = mxewma_psi (*l, *c, *p, *r, PSI, w, z); if ( *type == cycl ) zahl = mxewma_psiS(*l, *c, *p, *hs, *r, PSI, w, z); zeug[0] = zahl; for (i = 1; i <= *r; i++) { zeug[i] = PSI[i-1]; zeug[i + *r] = w[i-1]; zeug[i + *r + *r] = z[i-1]; } Free(z); Free(w); Free(PSI); } spc/src/xsewma_sf.c0000644000176200001440000000213413553640534013776 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 double *vector (long n); double xseU_sf(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0); double xse2_sf(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0); void xsewma_sf ( int *ctyp, double *lx, double *cx, double *hsx, int *Nx, double *ls, double *csl, double *csu, double *hss, int *Ns, double *mu, double *sigma, int *df, int *qm, int *n, double *sf) { int result=0, i; double *p0; p0 = vector(*n); if ( *ctyp == ewmaU ) result = xseU_sf(*lx, *ls, *cx, *csu, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, *n, *qm, p0); if ( *ctyp == ewma2 ) result = xse2_sf(*lx, *ls, *cx, *csl, *csu, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, *n, *qm, p0); if ( result != 0 ) warning("trouble in xsewma_sf [package spc]"); for (i=0; i<*n; i++) sf[i] = p0[i]; } spc/src/xtewma_arl.c0000644000176200001440000000257213553640534014153 0ustar liggesusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 extern double rho0; double *vector (long n); double xte2_iglarl(double l, double c, double hs, int df, double mu, int N, int subst); double xte2_arlm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst); double xte2_arlm_hom(double l, double c, double hs, int df, int q, double mu0, double mu1, int N, double *ced, int subst); double xte1_iglarl(double l, double c, double zr, double hs, int df, double mu, int N, int subst); void xtewma_arl(int *ctyp, double *l, double *c, double *zr, double *hs, int *df, double *mu, int *ltyp, int *r, int *ntyp, int *q, double *arl) { int nmax=100000, i, result=0; double *ced, arl1=-1.; ced = vector(*q); if (*ctyp==ewma2 && *ltyp==fix && *q==1) arl1 = xte2_iglarl(*l,*c,*hs,*df,*mu,*r,*ntyp); if (*ctyp==ewma1 && *ltyp==fix && *q==1) arl1 = xte1_iglarl(*l,*c,*zr,*hs,*df,*mu,*r,*ntyp); if (*ctyp==ewma2 && *ltyp==fix && *q>1) result = xte2_arlm_hom(*l,*c,*hs,*df,*q,0.,*mu,*r,ced,*ntyp); if (*ctyp==ewma2 && *ltyp>fix ) arl1 = xte2_arlm(*l,*c,*hs,*df,*q,0.,*mu,*ltyp,*r,nmax,*ntyp); if ( result != 0 ) warning("trouble in xtewma_arl [package spc]"); if ( *ltyp==fix && *q>1 ) for (i=0; i<*q; i++) arl[i] = ced[i]; else *arl = arl1; } spc/src/xgrsr_arl.c0000644000176200001440000000210213553640534014000 0ustar liggesusers#include #include #include #include #define grsr1 0 #define grsr2 1 extern double rho0; double *vector (long n); double xsr1_iglarl(double k, double h, double zr, double hs, double mu, int N, int MPT); double xsr1_arlm(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int nmax, int MPT); double xsr1_arlm_hom(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int MPT, double *ced); void xgrsr_arl(int *ctyp, double *k, double *h, double *zr, double *hs, double *mu, int *q, int *r, int *MPT, double *arl) { int i, /*nmax=100000,*/ result=0; double *ced, arl1=-1.; ced = vector(*q); if ( *ctyp==grsr1 && *q==1 ) arl1 = xsr1_iglarl(*k, *h, *zr, *hs, *mu, *r, *MPT); if ( *ctyp==grsr1 && *q>1 ) result = xsr1_arlm_hom(*k, *h, *zr, *hs, *q, 0., *mu, *r, *MPT, ced); /* *arl = xsr1_arlm(*k, *h, *zr, *hs, *q, 0., *mu, *r, nmax, *MPT);*/ if ( result != 0 ) warning("trouble in xgrsr_arl [package spc]"); if ( *q > 1 ) for (i=0; i<*q; i++) arl[i] = ced[i]; else *arl = arl1; } spc/src/xgrsr_crit.c0000644000176200001440000000057213553640534014174 0ustar liggesusers#include #include #include #include #define grsr1 0 #define grsr2 1 extern double rho0; double xsr1_crit(double k, double L0, double zr, double hs, double m0, int N, int MPT); void xgrsr_crit(double *k, double *L0, double *zr, double *hs, double *mu0, int *r, int *MPT, double *h) { *h = xsr1_crit(*k, *L0, *zr, *hs, *mu0, *r, *MPT); } spc/src/Makevars0000644000176200001440000000006013553640534013326 0ustar liggesusersPKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) spc/src/mewma_arl.c0000644000176200001440000001062713553640534013754 0ustar liggesusers#include #include #include #include #define GL 0 #define CO 1 #define RA 2 #define CC 3 #define MC 4 #define SR 5 #define CO2 6 #define GL2 7 #define GL3 8 #define GL4 9 #define GL5 10 #define CO3 11 #define CO4 12 #define nGL1 13 #define nGL2 14 #define nGL3 15 #define nGL4 16 #define nGL5 17 double mxewma_arl_0a(double lambda, double ce, int p, double hs, int N); double mxewma_arl_0a2(double lambda, double ce, int p, double hs, int N); double mxewma_arl_0b(double lambda, double ce, int p, double hs, int N, int qm); double mxewma_arl_0c(double lambda, double ce, int p, double hs, int N); double mxewma_arl_0d(double lambda, double ce, int p, double hs, int N); double mxewma_arl_0e(double lambda, double ce, int p, double hs, int N); double mxewma_arl_0f(double lambda, double ce, int p, double hs, int N); double mxewma_arl_1a(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1a2(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1a3(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1a4(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1a5(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1b(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); double mxewma_arl_1b2(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); double mxewma_arl_1b3(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); double mxewma_arl_1b4(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); double mxewma_arl_1c(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1d(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1e(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1f(double lambda, double ce, int p, double delta, double hs, int N); double mxewma_arl_1q(double lambda, double ce, int p, double delta, int N); double mxewma_arl_1r(double lambda, double ce, int p, double delta, int N); double mxewma_arl_1s(double lambda, double ce, int p, double delta, int N); double mxewma_arl_1t(double lambda, double ce, int p, double delta, int N); double mxewma_arl_1u(double lambda, double ce, int p, double delta, int N); void mewma_arl(double *l, double *c, int *p, double *delta, double *hs, int *r, int *qtype, int *qm0, int *qm1, double *arl) { if ( fabs(*delta)<1e-10 ) { if ( *qtype == GL ) *arl = mxewma_arl_0a(*l, *c, *p, *hs, *r); if ( *qtype == GL2 ) *arl = mxewma_arl_0a2(*l, *c, *p, *hs, *r); if ( *qtype == CO ) *arl = mxewma_arl_0b(*l, *c, *p, *hs, *r, *qm0); if ( *qtype == RA ) *arl = mxewma_arl_0c(*l, *c, *p, *hs, *r); if ( *qtype == CC ) *arl = mxewma_arl_0d(*l, *c, *p, *hs, *r); if ( *qtype == MC ) *arl = mxewma_arl_0e(*l, *c, *p, *hs, *r); if ( *qtype == SR ) *arl = mxewma_arl_0f(*l, *c, *p, *hs, *r); } else { if ( *qtype == GL ) *arl = mxewma_arl_1a(*l, *c, *p, *delta, *hs, *r); if ( *qtype == GL2 ) *arl = mxewma_arl_1a2(*l, *c, *p, *delta, *hs, *r); if ( *qtype == GL3 ) *arl = mxewma_arl_1a3(*l, *c, *p, *delta, *hs, *r); if ( *qtype == GL4 ) *arl = mxewma_arl_1a4(*l, *c, *p, *delta, *hs, *r); if ( *qtype == GL5 ) *arl = mxewma_arl_1a5(*l, *c, *p, *delta, *hs, *r); if ( *qtype == nGL1 ) *arl = mxewma_arl_1q(*l, *c, *p, *delta, *r); if ( *qtype == nGL2 ) *arl = mxewma_arl_1r(*l, *c, *p, *delta, *r); if ( *qtype == nGL3 ) *arl = mxewma_arl_1s(*l, *c, *p, *delta, *r); if ( *qtype == nGL4 ) *arl = mxewma_arl_1t(*l, *c, *p, *delta, *r); if ( *qtype == nGL5 ) *arl = mxewma_arl_1u(*l, *c, *p, *delta, *r); if ( *qtype == CO ) *arl = mxewma_arl_1b(*l, *c, *p, *delta, *hs, *r, *qm0, *qm1); if ( *qtype == CO2 ) *arl = mxewma_arl_1b2(*l, *c, *p, *delta, *hs, *r, *qm0, *qm1); if ( *qtype == CO3 ) *arl = mxewma_arl_1b3(*l, *c, *p, *delta, *hs, *r, *qm0, *qm1); if ( *qtype == CO4 ) *arl = mxewma_arl_1b4(*l, *c, *p, *delta, *hs, *r, *qm0, *qm1); if ( *qtype == RA ) *arl = mxewma_arl_1c(*l, *c, *p, *delta, *hs, *r); if ( *qtype == CC ) *arl = mxewma_arl_1d(*l, *c, *p, *delta, *hs, *r); if ( *qtype == MC ) *arl = mxewma_arl_1e(*l, *c, *p, *delta, *hs, *r); if ( *qtype == SR ) *arl = mxewma_arl_1f(*l, *c, *p, *delta, *hs, *r); } } spc/src/ewma_phat_lambda_coll.c0000644000176200001440000000142313553640534016260 0ustar liggesusers#include #include #include #include double ewma_phat_lambda(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm); double ewma_phat_lambda2(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm, int M); void ewma_phat_lambda_coll (double *L0, double *mu, double *sigma, int *ctyp, double *max_l, double *min_l, int *n, double *z0, double *LSL, double *USL, int *qm, double *lambda) { int M=4; *lambda = -1.; if ( *ctyp == 0 ) *lambda = ewma_phat_lambda(*L0, *mu, *sigma, *max_l, *min_l, *n, *z0, *LSL, *USL, *qm); if ( *ctyp == 1 ) *lambda = ewma_phat_lambda2(*L0, *mu, *sigma, *max_l, *min_l, *n, *z0, *LSL, *USL, *qm, M); } spc/src/sewma_sf_prerun.c0000644000176200001440000000552013553640534015203 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 double *vector (long n); double seU_sf_prerun_SIGMA_deluxe(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seU_sf_prerun_SIGMA(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seUR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seUR_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double se2_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double se2_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seLR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seLR_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); void sewma_sf_prerun ( int *ctyp, double *l, double *cl, double *cu, double *hs, double *sigma, int *df1, int *qm1, int *n, int *df2, int *qm2, double *truncate, int *tail_approx, double *sf) { int result=0, i; double *p0; p0 = vector(*n); if ( *ctyp == ewmaU ) { if ( *tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(*l, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); else result = seU_sf_prerun_SIGMA(*l, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); } if ( *ctyp == ewmaUR ) { if ( *tail_approx ) result = seUR_sf_prerun_SIGMA_deluxe(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); else result = seUR_sf_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); } if ( *ctyp == ewma2 ) { if ( *tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); else result = se2_sf_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); } if ( *ctyp == ewmaLR ) { if ( *tail_approx ) result = seLR_sf_prerun_SIGMA_deluxe(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); else result = seLR_sf_prerun_SIGMA(*l, *cl, *cu, *hs, *sigma, *df1, *df2, *n, *qm1, *qm2, *truncate, p0); } if ( result != 0 ) warning("trouble in sewma_sf_prerun [package spc]"); for (i=0; i<*n; i++) sf[i] = p0[i]; } spc/src/xewma_arl.c0000644000176200001440000000644113553640534013766 0ustar liggesusers#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 #define conditional 0 #define cyclical 1 extern double rho0; double *vector (long n); double xe1_iglarl(double l, double c, double zr, double hs, double mu, int N); double xe1_arlm(double l, double c, double zr, double hs, int q, double mu0, double mu1,int mode, int N, int nmax); double xe1_arlm_hom(double l, double c, double zr, double hs, int q, double mu0, double mu1, int N, double *ced); double xlimit1_arlm(double c, double zr, int q, double mu0, double mu1, int N, int nmax); double xe1_Warl(double l, double c, double zr, double hs, double mu, int N, int nmax); double xe2_iglarl(double l, double c, double hs, double mu, int N); double xe2_Warl(double l, double c, double hs, double mu, int N, int nmax); double xe2_Carl(double l, double c, double hs, double mu, int N, int qm); double xe2_arlm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); double xe2_arlmc(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); double xe2_arlm_hom(double l, double c, double hs, int q, double mu0, double mu1, int N, double *ced); void xewma_arl(int *ctyp, double *l, double *c, double *zr, double *hs, double *mu, int *ltyp, int *r, int *q, int *styp, double *arl) { int nmax=100000, i, result=0; double *ced, arl1=-1.; ced = vector(*q); if (*ctyp==ewma1 && *ltyp==fix && *q==1) arl1 = xe1_iglarl(*l,*c,*zr,*hs,*mu,*r); if (*ctyp==ewma1 && *ltyp==fix && *q>1) result = xe1_arlm_hom(*l, *c, *zr, *hs, *q, 0., *mu, *r, ced); /* *arl = xe1_arlm(*l,*c,*zr,*hs,*q,0.,*mu,*ltyp,*r,nmax);*/ if (*ctyp==ewma1 && *ltyp>fix && *ltyp1 && *styp==conditional) result = xe2_arlm_hom(*l, *c, *hs, *q, 0., *mu, *r, ced); /* arl1 = xe2_arlm(*l,*c,*hs,*q,0.,*mu,*ltyp,*r,nmax);*/ if (*ctyp==ewma2 && *ltyp==fix && *q>1 && *styp==cyclical) arl1 = xe2_arlmc(*l,*c,*hs,*q,0.,*mu,*ltyp,*r,nmax); if (*ctyp==ewma2 && *ltyp>fix && *ltypfix && *ltyp1 && *styp==conditional ) for (i=0; i<*q; i++) arl[i] = ced[i]; else *arl = arl1; } spc/src/sewma_q.c0000644000176200001440000000212013553640534013431 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 double seU_Wq(double l, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); double se2_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); double seUR_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); double seLR_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); void sewma_q(int *ctyp, double *l, double *cl, double *cu, double *p, double *hs, int *N, double *sigma, int *df, int *qm, double *tq) { int nmax=100000; if ( *ctyp == ewmaU ) *tq = seU_Wq(*l, *cu, *p, *hs, *sigma, *df, *N, nmax, *qm); if ( *ctyp == ewma2 ) *tq = se2_Wq(*l, *cl, *cu, *p, *hs, *sigma, *df, *N, nmax, *qm); if ( *ctyp == ewmaUR ) *tq = seUR_Wq(*l, *cl, *cu, *p, *hs, *sigma, *df, *N, nmax, *qm); if ( *ctyp == ewmaLR ) *tq = seLR_Wq(*l, *cl, *cu, *p, *hs, *sigma, *df, *N, nmax, *qm); } spc/src/xcusum_q.c0000644000176200001440000000055413553640534013652 0ustar liggesusers#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/scusum_crit.c0000644000176200001440000000202613553640534014342 0ustar liggesusers#include #include #include #include #define cusumU 0 #define cusumL 1 #define cusum2 2 double scU_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm); double scL_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm); int sc2_crit_unbiased(double refkl, double refku, double L0, double *hl, double *hu, double hsl, double hsu, double sigma, int df, int N, int qm); void scusum_crit(int *ctyp, double *k, double *L0, double *hs, double *sigma, int *df, int *ltyp, double *k2, double *hs2, int *r, int *qm, double *h) { int result=0; double hl=0., hu=0.; if ( *ctyp==cusumU ) *h = scU_crit(*k, *L0, *hs, *sigma, *df, *r, *qm); if ( *ctyp==cusumL ) *h = scL_crit(*k, *L0, *hs, *sigma, *df, *r, *qm); if ( *ctyp==cusum2 ) { result = sc2_crit_unbiased(*k2, *k, *L0, &hl, &hu, *hs2, *hs, *sigma, *df, *r, *qm); if ( result != 0 ) warning("trouble with sc2_crit_unbiased called from scusum_crit [package spc]"); h[0] = hl; h[1] = hu; } } spc/src/xsewma_q_crit.c0000644000176200001440000000336613553640534014657 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewma2 1 #define fixed 0 #define unbiased 1 int xseU_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error); int xse2fu_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error); int xse2_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error); void xsewma_q_crit ( int *ctyp, int *ltyp, double *lx, double *ls, double *L0, double *alpha, double *cu0, double *hsx, double *hss, double *mu, double *sigma, int *df, int *Nx, int *Ns, int *qm, double *c_error, double *a_error, double *c_values) { int result=0; double cx=-1., cl=0., cu=-1.; if ( *ctyp==ewmaU ) result = xseU_q_crit(*lx, *ls, *L0, *alpha, &cx, &cu, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, *qm, *c_error, *a_error); if ( *ctyp==ewma2 ) { if ( *ltyp==fixed ) { result = xse2fu_q_crit(*lx, *ls, *L0, *alpha, &cx, &cl, *cu0, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, *qm, *c_error, *a_error); cu = *cu0; } if ( *ltyp==unbiased ) result = xse2_q_crit(*lx, *ls, *L0, *alpha, &cx, &cl, &cu, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, *qm, *c_error, *a_error); } if ( result != 0 ) warning("trouble with xsewma_q_crit [package spc]"); c_values[0] = cx; c_values[1] = cl; c_values[2] = cu; } spc/src/mewma_arl_f.c0000644000176200001440000001613313553640534014257 0ustar liggesusers#include #include #include #include #define GL 0 #define CO 1 #define RA 2 #define CC 3 #define MC 4 #define SR 5 #define CO2 6 #define GL2 7 #define GL3 8 #define GL4 9 #define GL5 10 #define CO3 11 #define CO4 12 #define nGL1 13 #define nGL2 14 #define nGL3 15 #define nGL4 16 #define nGL5 17 double mxewma_arl_f_0a(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0a2(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0b(double lambda, double ce, int p, int N, int qm, double *ARL); double mxewma_arl_f_0c(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0d(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0e(double lambda, double ce, int p, int N, double *ARL, double *z); double mxewma_arl_f_0f(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_1a (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL class */ double mxewma_arl_f_1a2(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL mod */ double mxewma_arl_f_1a3(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod sin, default for 2 and 4 */ double mxewma_arl_f_1a4(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod tan */ double mxewma_arl_f_1a5(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod sinh, default for all other p */ double mxewma_arl_f_1b (double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step + sin() */ double mxewma_arl_f_1b3(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step */ double mxewma_arl_f_1b2(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with shrinked supports of the outer integral */ double mxewma_arl_f_1b4(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step + sinh() instead of sin() */ double mxewma_arl_f_1c (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL + Radau (Rigdon) */ double mxewma_arl_f_1d (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* Clenshaw-Curtis */ double mxewma_arl_f_1e (double lambda, double ce, int p, double delta, int N, double *g, int *dQ); /* Markov Chain (Runger/Prabhu) */ double mxewma_arl_f_1f (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z); /* Simpson rule */ double mxewma_arl_f_1q (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL, changed integration order */ double mxewma_arl_f_1r (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); double mxewma_arl_f_1s (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); double mxewma_arl_f_1t (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); double mxewma_arl_f_1u (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); double *vector (long n); void mewma_arl_f(double *l, double *c, int *p, double *delta, int *r, int *qtype, int *qm0, int *qm1, double *zeug) { double *ARL, *w, *z, *w1, *z1, zahl=0.; int i, j, r2, dQ; if ( fabs(*delta)<1e-10 ) { ARL = vector(*r); w = vector(*r); z = vector(*r); for (i = 0; i < *r; i++) { w[i] = -1.; z[i] = 0.; } /* init */ if ( *qtype == GL ) zahl = mxewma_arl_f_0a (*l, *c, *p, *r, ARL, w, z); if ( *qtype == GL2 ) zahl = mxewma_arl_f_0a2(*l, *c, *p, *r, ARL, w, z); if ( *qtype == CO ) zahl = mxewma_arl_f_0b (*l, *c, *p, *r, *qm0, ARL); if ( *qtype == RA ) zahl = mxewma_arl_f_0c (*l, *c, *p, *r, ARL, w, z); if ( *qtype == CC ) zahl = mxewma_arl_f_0d (*l, *c, *p, *r, ARL, w, z); if ( *qtype == MC ) zahl = mxewma_arl_f_0e (*l, *c, *p, *r, ARL, z); if ( *qtype == SR ) zahl = mxewma_arl_f_0f (*l, *c, *p, *r, ARL, w, z); for (i = 0; i < *r; i++) { zeug[i] = ARL[i]; zeug[i + *r] = w[i]; zeug[i + *r + *r] = z[i]; } Free(z); Free(w); Free(ARL); } else { r2 = (*r) * (*r); ARL = vector(r2); w = vector(*r); z = vector(*r); w1 = vector(*r); z1 = vector(*r); if ( *qtype == GL ) zahl = mxewma_arl_f_1a (*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == GL2 ) zahl = mxewma_arl_f_1a2(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == GL3 ) zahl = mxewma_arl_f_1a3(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == GL4 ) zahl = mxewma_arl_f_1a4(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == GL5 ) zahl = mxewma_arl_f_1a5(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == nGL1 ) zahl = mxewma_arl_f_1q(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == nGL2 ) zahl = mxewma_arl_f_1r(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == nGL3 ) zahl = mxewma_arl_f_1s(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == nGL4 ) zahl = mxewma_arl_f_1t(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == nGL5 ) zahl = mxewma_arl_f_1u(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == CO ) zahl = mxewma_arl_f_1b (*l, *c, *p, *delta, *r, *qm0, *qm1, ARL); if ( *qtype == CO2 ) zahl = mxewma_arl_f_1b2(*l, *c, *p, *delta, *r, *qm0, *qm1, ARL); if ( *qtype == CO3 ) zahl = mxewma_arl_f_1b3(*l, *c, *p, *delta, *r, *qm0, *qm1, ARL); if ( *qtype == CO4 ) zahl = mxewma_arl_f_1b4(*l, *c, *p, *delta, *r, *qm0, *qm1, ARL); if ( *qtype == RA ) zahl = mxewma_arl_f_1c(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == CC ) zahl = mxewma_arl_f_1d(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype == MC ) zahl = mxewma_arl_f_1e(*l, *c, *p, *delta, *r, zeug, &dQ); if ( *qtype == SR ) zahl = mxewma_arl_f_1f(*l, *c, *p, *delta, *r, ARL, w, z, w1, z1); if ( *qtype != MC ) { for (i = 0; i < *r; i++) { for (j = 0; j < *r; j++) zeug[ i*(*r) + j ] = ARL[ i*(*r) + j ]; zeug[i + r2] = w[i]; zeug[i + r2 + *r] = z[i]; zeug[i + r2 + 2*(*r)] = w1[i]; zeug[i + r2 + 3*(*r)] = z1[i]; } } /*else { printf("\n\ndQ = %d\n\n", dQ); for (i=0; i < dQ; i++) zeug[i] = ARL[i]; } */ Free(z1); Free(w1); Free(z); Free(w); Free(ARL); } if ( fabs(zahl) > 1e-9 ) warning("trouble in mewma_arl_f [package spc]"); } spc/src/allspc.c0000644000176200001440000261176614325474576013314 0ustar liggesusers#include #include #include #include #include #include #include #include #include #define LOG 0 #define TAIL 1 #define cusum1 0 #define cusum2 1 #define cusumC 2 #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define stat 5 #define fink 6 #define FINALeps 1e-12 #define lmEPS 1e-4 #define IDENTITY 0 #define SIN 1 #define SINH 2 #define TAN 3 /*** export ***/ /* CUSUM */ double xc_crit(int ctyp, double k, double L0, double hs, double m0, int N); /* one-sided CUSUM */ double xc1_iglarl(double k, double h, double hs, double mu, int N); double xc1_be_arl(double k, double h, double hs, double mu, int N); double xc1_beL_arl(double k, double h, double hs, double mu, int N); double xc1_beT_arl(double k, double h, double hs, double mu, int N); double xc1_iglad (double k, double h, double mu0, double mu1, int N); double xc1_iglarl_drift(double k, double h, double hs, double delta, int m, int N, int with0); double xc1_iglarl_drift_wo_m(double k, double h, double hs, double delta, int *m, int N, int with0); double xc1_iglarlm_drift(double k, double h, double hs, int q, double delta, int N, int nmax, int with0); double xtc1_iglarl(double k, double h, double hs, int df, double mu, int N, int subst); double xc1_Wq(double k, double h, double p, double hs, double mu, int N, int nmax); double xc1_sf(double k, double h, double hs, double mu, int N, int nmax, double *p0); double xc1_arlm(double k, double h, double hs, int q, double mu0, double mu1, int N, int nmax); double xc1_arlm_hom(double k, double h, double hs, int q, double mu0, double mu1, int N, double *ced); /* classical two-sided (2 charts) CUSUM */ double xc2_iglarl(double k, double h, double hs, double mu, int N); double xc2_be_arl(double k, double h, double hs1, double hs2, double mu, int N); double xc2_be_arlm(double k, double h, double hs1, double hs2, int q, double mu0, double mu1, int N, double *ced); double xc2_iglad (double k, double h, double mu0, double mu1, int N); double xc2_iglarl_drift(double k, double h, double hs, double delta, int m, int N, int drift0); /* it is not accurate */ double xc2_iglarl_drift_wo_m(double k, double h, double hs, double delta, int *m, int N, int drift0); /* it is not accurate */ double xtc2_iglarl(double k, double h, double hs, int df, double mu, int N, int subst); /* Crosier's two-sided CUSUM */ double xcC_iglarl(double k, double h, double hs, double mu, int N); double xcC_iglad (double k, double h, double mu0, double mu1, int N); /* variance charts */ double scU_iglarl_v1(double refk, double h, double hs, double sigma, int df, int N, int qm); double scU_iglarl_v2(double refk, double h, double hs, double sigma, int df, int N, int qm); double scL_iglarl_v2(double refk, double h, double hs, double sigma, int df, int N, int qm); double sc2_iglarl_v2(double refkl, double refku, double hl, double hu, double hsl, double hsu, double sigma, int df, int N, int qm); double scU_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm); double scL_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm); double scU_fl_crit(double refkl, double refku, double hl, double L0, double hsl, double hsu, double sigma, int df, int N, int qm); double scL_fu_crit(double refkl, double refku, double hu, double L0, double hsl, double hsu, double sigma, int df, int N, int qm); int sc2_crit_unbiased(double refkl, double refku, double L0, double *hl, double *hu, double hsl, double hsu, double sigma, int df, int N, int qm); /*double sc2_eqtails(double refkl, double refku, double L0, double *hl, double *hu, double hsl, double hsu, double sigma, int df, int N, int qm);*/ /* CUSUM-Shewhart combo */ double scs_U_iglarl_v1(double refk, double h, double hs, double cS, double sigma, int df, int N, int qm); /* Shiryaev-Roberts (only the one-sided version is implemented) */ double xsr1_crit(double k, double L0, double zr, double hs, double m0, int N, int MPT); double xsr1_iglarl(double k, double h, double zr, double hs, double mu, int N, int MPT); double xsr1_iglad(double k, double h, double zr, double mu0, double mu1, int N, int MPT); double xsr1_arlm(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int nmax, int MPT); double xsr1_arlm_hom(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int MPT, double *ced); double xsr1_iglarl_drift(double k, double h, double zr, double hs, double delta, int m, int N, int with0); double xsr1_iglarl_drift_wo_m(double k, double h, double zr, double hs, double delta, int *m, int N, int with0); double xsr1_iglarlm_drift(double k, double h, double zr, double hs, int q, double delta, int N, int nmax, int with0); /* EWMA */ double xe_crit(int ctyp, double l, double L0, double zr, double hs, double m0, int ltyp, int N, double c0); double xe_q_crit(int ctyp, double l, int L0, double alpha, double zr, double hs, double m0, int ltyp, int N, double c_error, double a_error); /* one-sided EWMA */ double xe1_iglarl(double l, double c, double zr, double hs, double mu, int N); double xe1_iglad (double l, double c, double zr, double mu0, double mu1, int N); double xe1_arlm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); double xe1_arlm_hom(double l, double c, double zr, double hs, int q, double mu0, double mu1, int N, double *ced); double xe1_Warl(double l, double c, double zr, double hs, double mu, int N, int nmax); double xe1_Wq(double l, double c, double p, double zr, double hs, double mu, int N, int nmax); double xe1_sf(double l, double c, double zr, double hs, double mu, int N, int nmax, double *p0); double xe1_sfm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0); double xe1_Wqm(double l, double c, double p, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); double xe1_iglarl_drift(double l, double c, double zr, double hs, double delta, int m, int N, int with0); double xe1_iglarl_drift_wo_m(double l, double c, double zr, double hs, double delta, int *m, int N, int with0); double xe1_iglarlm_drift(double l, double c, double zr, double hs, int q, double delta, int N, int nmax, int with0); double xlimit1_arlm(double c, double zr, int q, double mu0, double mu1, int N, int nmax); /* two-sided EWMA */ double xe2_iglarl(double l, double c, double hs, double mu, int N); double xe2_iglarl_f(double l, double c, double mu, int N, double *g, double *w, double *z); double xe2_iglad (double l, double c, double mu0, double mu1, int N); double xe2_igladc(double l, double c, double mu0, double mu1, double z0, int N); double xe2_arlm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); double xe2_arlmc(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); int xe2_arlm_special(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *pair); double xe2_arlm_hom(double l, double c, double hs, int q, double mu0, double mu1, int N, double *ced); double xe2_Wq(double l, double c, double p, double hs, double mu, int N, int nmax); double xe2_sf(double l, double c, double hs, double mu, int N, int nmax, double *p0); double xe2_sfm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0); double xe2_Wqm(double l, double c, double p, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); double xe2_Warl(double l, double c, double hs, double mu, int N, int nmax); /* Waldmann's ARL procedure */ double xe2_Carl(double l, double c, double hs, double mu, int N, int qm); /* collocation */ double xe2_iglarl_drift(double l, double c, double hs, double delta, int m, int N, int with0); double xe2_iglarl_drift_wo_m(double l, double c, double hs, double delta, int *m, int N, int with0); double xe2_iglarlm_drift(double l, double c, double hs, int q, double delta, int N, int nmax, int with0); double xe2_Warl_drift(double l, double c, double hs, double delta, int N, int nmax, int with0); /* functions based on Srivastava & Wu (1997) */ double xe2_SrWu_crit(double l, double L0); double xe2_SrWu_arl(double l, double c, double mu); double xe2_SrWu_arl_full(double l, double c, double mu); double xe2_SrWu_lambda(double delta, double L0); /* t distribution */ double xte2_iglarl(double l, double c, double hs, int df, double mu, int N, int subst); double xte2_iglad (double l, double c, int df, double mu0, double mu1, int N, int subst); double xte2_igladc(double l, double c, int df, double mu0, double mu1, double z0, int N, int subst); double xte2_arlm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst); double xte2_arlm_hom(double l, double c, double hs, int df, int q, double mu0, double mu1, int N, double *ced, int subst); double xte2_Wq(double l, double c, double p, double hs, int df, double mu, int N, int nmax, int subst); double xte2_sf(double l, double c, double hs, int df, double mu, int N, int nmax, double *p0, int subst); double xte2_sfm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0, int subst); double xte2_Wqm(double l, double c, double p, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst); double xte1_iglarl(double l, double c, double zr, double hs, int df, double mu, int N, int subst); /* incorporate pre-run uncertainty */ double xe2_iglarl_prerun_MU(double l, double c, double hs, double mu, int pn, int qm, double truncate); double xe2_iglarl_prerun_SIGMA(double l, double c, double hs, double mu, int pn, int qm, double truncate); double xe2_iglarl_prerun_BOTH(double l, double c, double hs, double mu, int pn, int df, int qm1, int qm2, double truncate); double xe2_arlm_prerun_MU(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate); double xe2_arlm_prerun_SIGMA(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate); double xe2_arlm_prerun_BOTH(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate); double xe2_sf_deluxe(double l, double c, double hs, double mu, int N, int nmax, double BOUND, double *p0, int *nstop, double *rho); double xe2_sf_prerun_MU_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sf_prerun_MU(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double *p0); double xe2_sf_prerun_SIGMA_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sf_prerun_SIGMA(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double *p0); double xe2_sf_prerun_BOTH_deluxe(double l, double c, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double BOUND, double *p0); double xe2_sf_prerun_BOTH(double l, double c, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double *p0); double xe2_sfm_simple(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0); double xe2_sfm_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double BOUND, double *p0, int *nstop, double *rho); double xe2_sfm_prerun_MU_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sfm_prerun_MU(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double *p0); double xe2_sfm_prerun_SIGMA_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sfm_prerun_SIGMA(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double *p0); double xe2_sfm_prerun_BOTH_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double BOUND, double *p0); double xe2_sfm_prerun_BOTH(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double *p0); double xe2_Wq_prerun_MU_deluxe(double l, double c, double p, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND); double xe2_Wq_prerun_SIGMA_deluxe(double l, double c, double p, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND); double xe2_Wq_prerun_BOTH_deluxe(double l, double c, double p, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double BOUND); double xe2_Wqm_prerun_MU_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND); double xe2_Wqm_prerun_SIGMA_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND); double xe2_Wqm_prerun_BOTH_deluxe(double l, double c, double p, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double BOUND); /* EWMA residual charts */ double xe2_iglarl_RES(double l, double c, double hs, double mu, int N, double alpha, int df); double seU_iglarl_RES(double l, double cu, double hs, double sigma, int df, int N, int qm, double alpha, double mu); double xseU_arl_RES(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double alpha); double xseU_mu_before_sigma_RES(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double alpha, int vice_versa); /* modified Shewhart charts for dependent data */ double x_shewhart_ar1_arl(double alpha, double cS, double mu, int N1, int N2); double t_shewhart_ar1_arl(double alpha, double cS, double delta, int df, int N1, int N2, int N3, double INF, int subst); /* variance charts */ double seU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm); double se2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double seUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double seLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double stdeU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm); double stde2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double stdeUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double stdeLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm); double lns2ewmaU_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N); double lns2ewma2_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N); double seU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm); double se2lu_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm); double se2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); int se2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm); int se2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm); double se2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm); double seUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm); double seLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); double stdeU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm); double stde2lu_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm); double stde2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); int stde2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm); int stde2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm); double stde2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm); double stdeUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm); double stdeLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm); double lns2ewmaU_crit(double l, double L0, double cl, double hs, double sigma, int df, int N); double lns2ewma2_crit_cufix(double l, double cu, double L0, double hs, double sigma, int df, int N); double lns2ewma2_crit_sym(double l, double L0, double hs, double sigma, int df, int N); int lns2ewma2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N); double seU_sf(double l, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); double seU_sf_deluxe(double l, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho); double se2_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); double se2_sf_deluxe(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho); double seUR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); double seUR_sf_deluxe(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho); double seLR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0); double seLR_sf_deluxe(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0, int *nstop, double *rho); double seU_q_crit(double l, int L0, double alpha, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); double se2lu_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); double se2fu_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); int se2_q_crit(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); int se2_q_crit_class(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm, double c_error, double a_error); double seUR_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); double seLR_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error); double seU_Wq(double l, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); double se2_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); double seUR_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); double seLR_Wq(double l, double cl, double cu, double p, double hs, double sigma, int df, int N, int nmax, int qm); /* MEWMA: Rigdon (1995a,b) */ double mxewma_arl_0a(double lambda, double ce, int p, double hs, int N); /* GL class */ double mxewma_arl_0a2(double lambda, double ce, int p, double hs, int N); /* GL mod */ double mxewma_arl_0b(double lambda, double ce, int p, double hs, int N, int qm); /* collocation */ double mxewma_arl_0c(double lambda, double ce, int p, double hs, int N); /* Radau (Rigdon) */ double mxewma_arl_0d(double lambda, double ce, int p, double hs, int N); /* Clenshaw-Curtis */ double mxewma_arl_0e(double lambda, double ce, int p, double hs, int N); /* Markov chain (Runger/Prabhu) */ double mxewma_arl_0f(double lambda, double ce, int p, double hs, int N); /* Simpson rule (poor performance) */ double mxewma_arl_f_0a(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0a2(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0b(double lambda, double ce, int p, int N, int qm, double *ARL); double mxewma_arl_f_0c(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0d(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_f_0e(double lambda, double ce, int p, int N, double *ARL, double *z); double mxewma_arl_f_0f(double lambda, double ce, int p, int N, double *ARL, double *w, double *z); double mxewma_arl_1a (double lambda, double ce, int p, double delta, double hs, int N); /* GL class */ double mxewma_arl_1a2(double lambda, double ce, int p, double delta, double hs, int N); /* GL mod */ double mxewma_arl_1a3(double lambda, double ce, int p, double delta, double hs, int N); /* GL again mod sin, default for 2 and 4 */ double mxewma_arl_1a4(double lambda, double ce, int p, double delta, double hs, int N); /* GL again mod tan */ double mxewma_arl_1a5(double lambda, double ce, int p, double delta, double hs, int N); /* GL again mod sinh, default for all other p */ double mxewma_arl_1q (double lambda, double ce, int p, double delta, int N); /* GL, changed integration order */ double mxewma_arl_1r (double lambda, double ce, int p, double delta, int N); double mxewma_arl_1s (double lambda, double ce, int p, double delta, int N); double mxewma_arl_1t (double lambda, double ce, int p, double delta, int N); double mxewma_arl_1u (double lambda, double ce, int p, double delta, int N); double mxewma_arl_f_1a (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL class */ double mxewma_arl_f_1a2(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL mod */ double mxewma_arl_f_1a3(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod sin, default for 2 and 4 */ double mxewma_arl_f_1a4(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod tan */ double mxewma_arl_f_1a5(double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL again mod sinh, default for all other p */ double mxewma_arl_f_1q (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL, changed integration order */ double mxewma_arl_f_1r (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); double mxewma_arl_f_1s (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); double mxewma_arl_f_1t (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); double mxewma_arl_f_1u (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); double mxewma_arl_1b(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); /* collocation */ double mxewma_arl_1b2(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); /* collocation, trimmed support of outer integral */ double mxewma_arl_1b3(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); /* collocation, tan instead of sin */ double mxewma_arl_1b4(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1); /* collocation, sinh instead of sin */ double mxewma_arl_1c(double lambda, double ce, int p, double delta, double hs, int N); /* Radau (Rigdon) */ double mxewma_arl_1d(double lambda, double ce, int p, double delta, double hs, int N); /* Clenshaw-Curtis */ double mxewma_arl_1e(double lambda, double ce, int p, double delta, double hs, int N); /* Markov chain (Runger/Prabhu) */ double mxewma_arl_1f(double lambda, double ce, int p, double delta, double hs, int N); /* Simpson rule (poor performance) */ double mxewma_arl_f_1b (double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step + sin() */ double mxewma_arl_f_1b3(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step */ double mxewma_arl_f_1b2(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with shrinked supports of the outer integral */ double mxewma_arl_f_1b4(double lambda, double ce, int p, double delta, int N, int qm0, int qm1, double *g); /* collocation with two halfs in the same step + sinh() instead of sin() */ double mxewma_arl_f_1c (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* GL + Radau (Rigdon) */ double mxewma_arl_f_1d (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z1); /* Clenshaw-Curtis */ double mxewma_arl_f_1e (double lambda, double ce, int p, double delta, int N, double *g, int *dQ); /* Markov Chain (Runger/Prabhu) */ double mxewma_arl_f_1f (double lambda, double ce, int p, double delta, int N, double *g, double *w0, double *z0, double *w1, double *z); /* Simpson rule */ double mxewma_crit(double lambda, double L0, int p, double hs, int N); double mxewma_psi (double lambda, double ce, int p, int N, double *PSI, double *w, double *z); double mxewma_psiS(double lambda, double ce, int p, double hs, int N, double *PSI, double *w, double *z); /* Markov chain (Runger/Prabhu) */ double mxewma_psi0_e(double lambda, double ce, int p, int N, double *PSI); double mxewma_psi1_e(double lambda, double ce, int p, int N, double *PSI); double mxewma_psiS0_e(double lambda, double ce, int p, int N, double *PSI); double mxewma_psiS1_e(double lambda, double ce, int p, int N, double *PSI); double mxewma_ad(double lambda, double ce, int p, double delta, int N, int qm2, int psi_type, double hs, int qtype, int qm0, int qm1); double mxewma_ad_new(double lambda, double ce, int p, double delta, int N, int psi_type, double hs, int qtype); /* Markov chain (Runger/Prabhu) */ double mxewma_ad_e(double lambda, double ce, int p, double delta, int psi_type, int N); /* incorporate pre-run uncertainty */ double seU_sf_prerun_SIGMA_deluxe(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seU_sf_prerun_SIGMA(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seUR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seUR_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double se2_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double se2_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seLR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seLR_sf_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0); double seU_iglarl_prerun_SIGMA(double l, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seUR_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double se2_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seLR_iglarl_prerun_SIGMA(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seU_q_crit_prerun_SIGMA(double l, int L0, double alpha, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double se2lu_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double se2fu_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double s0, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); int se2_q_crit_prerun_SIGMA(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double seUR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double seLR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error); double seU_Wq_prerun_SIGMA_deluxe(double l, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); double seUR_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); double seLR_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); double se2_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); double seU_crit_prerun_SIGMA(double l, double L0, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double se2lu_crit_prerun_SIGMA(double l, double L0, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double se2fu_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); int se2_crit_prerun_SIGMA(double l, double L0, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seUR_crit_prerun_SIGMA(double l, double L0, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); double seLR_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate); /* simultaneous EWMA charts */ double xseU_arl(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); double xse2_arl(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); int xseU_crit(double lx, double ls, double L0, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); int xse2lu_crit(double lx, double ls, double L0, double *cx, double csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); int xse2fu_crit(double lx, double ls, double L0, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); int xse2_crit(double lx, double ls, double L0, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); double xseU_sf(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0); double xseU_sf_deluxe(double lx, double ls, double cx, double cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0, int *nstop, double *rho); double xse2_sf(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0); double xse2_sf_deluxe(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm, double *p0, int *nstop, double *rho); int xseU_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error); int xse2fu_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error); int xse2_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error); double xseU_Wq(double lx, double ls, double cx, double cs, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); double xse2_Wq(double lx, double ls, double cx, double csl, double csu, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); /* EWMA p under sampling by variables */ double WK_h(double mu, double sigma, double LSL, double USL); double wk_h_mu(double mu, double sigma, double LSL, double USL); double wk_h_sigma(double mu, double sigma, double LSL, double USL); double WK_h_invers_mu(double p, double sigma, double LSL, double USL); double WK_h_invers_sigma(double p, double mu, double LSL, double USL); double wk_alpha(double p, double sigma, int n, double LSL, double USL); double cdf_phat(double p, double mu, double sigma, int n, double LSL, double USL); double pdf_phat(double p, double mu, double sigma, int n, double LSL, double USL); double qf_phat(double p0, double mu, double sigma, int n, double LSL, double USL); double wk_cdf_i(double y, double p, double mu, double sigma, int n, double LSL, double USL); double wk_pdf_i(double y, double p, double mu, double sigma, int n, double LSL, double USL); double cdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes); double pdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes); double qf_phat2(double p0, double mu, double sigma, int n, double LSL, double USL, int nodes); double ewma_phat_arl (double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm); double ewma_phat_arl_be(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N); double ewma_phat_crit(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm); double ewma_phat_lambda(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm); double ewma_phat_arl2 (double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M); double ewma_phat_arl2_be(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N); double ewma_phat_crit2(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M); double ewma_phat_lambda2(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm, int M); /* attribute EWMA p (X follows binomial distribution), old setup */ double ewma_pU_arl(double lambda, double ucl, int n, double p, double z0, int d_res, int round_mode, int mid_mode); double ewma_pL_arl(double lambda, double lcl, int n, double p, double z0, int d_res, int round_mode, int mid_mode); double ewma_p2_arl(double lambda, double lcl, double ucl, int n, double p, double z0, int d_res, int round_mode, int mid_mode); /* attribute EWMA p (X follows Poisson distribution) */ double cewma_U_arl(double lambda, double AU, double mu0, double z0, double mu, int N); double cewma_L_arl(double lambda, double AL, double AU, double mu0, double z0, double mu, int N); double cewma_2_arl(double lambda, double AL, double AU, double mu0, double z0, double mu, int N); double cewma_2_arl_rando(double lambda, double AL, double AU, double gammaL, double gammaU, double mu0, double z0, double mu, int N); double cewma_U_crit(double lambda, double L0, double mu0, double z0, int N, int jmax); double cewma_L_crit(double lambda, double L0, double AU, double mu0, double z0, int N, int jmax); double cewma_2_crit_sym(double lambda, double L0, double mu0, double z0, int N, int jmax); double cewma_2_crit_AL(double lambda, double L0, double AU, double mu0, double z0, int N, int jmax); double cewma_2_crit_AU(double lambda, double L0, double AL, double mu0, double z0, int N, int jmax); int cewma_2_crit_unb(double lambda, double L0, double mu0, double z0, int N, int jmax, double *AL, double *AU); double cewma_U_arl_new(double lambda, double AU, double mu0, double z0, double mu, int N); double cewma_L_arl_new(double lambda, double AL, double AU, double mu0, double z0, double mu, int N); double cewma_2_arl_new(double lambda, double AL, double AU, double mu0, double z0, double mu, int N); double cewma_2_Warl_new(double lambda, double AL, double AU, double mu0, double z0, double mu, int N, int nmax); double cewma_2_arl_rando_new(double lambda, double AL, double AU, double gammaL, double gammaU, double mu0, double z0, double mu, int N); double cewma_U_crit_new(double lambda, double L0, double mu0, double z0, int N, int jmax); double cewma_L_crit_new(double lambda, double L0, double AU, double mu0, double z0, int N, int jmax); double cewma_2_crit_sym_new(double lambda, double L0, double mu0, double z0, int N, int jmax); double cewma_2_crit_AL_new(double lambda, double L0, double AU, double mu0, double z0, int N, int jmax); double cewma_2_crit_AU_new(double lambda, double L0, double AL, double mu0, double z0, int N, int jmax); int cewma_2_crit_unb_new(double lambda, double L0, double mu0, double z0, int N, int jmax, double *AL, double *AU); int cewma_2_crit_unb_rando_new(double lambda, double L0, double mu0, double z0, int N, int jmax, double *AL, double *AU, double *gL, double *gU); double cewma_2_ad(double lambda, double AL, double AU, double mu0, double mu, int N); double cewma_2_ad_new(double lambda, double AL, double AU, double mu0, double mu, int N); /* TEWMA (thinning operation -- X follows Poisson distribution */ double tewma_arl(double lambda, int k, int lk, int uk, double z0, double mu); double tewma_arl_R(double lambda, int k, int lk, int uk, double gl, double gu, double z0, double mu); /* Rakitzis / Castagliola / Maravelakis (2015), A new memory-type monitoring technique for count data, doi 10.1016/j.cie.2015.03.021 */ double eewma_arl(int gX, int gY, int kL, int kU, double mu, double y0, int r0); /* attribute CUSUM (X follows Poisson distribution) */ double ccusum_U_arl(double mu, int km, int hm, int m, int i0); double ccusum_U_arl_rando(double mu, int km, int hm, int m, double gamma, int i0); int ccusum_U_crit(double A, double mu0, int km, int m, int i0); int ccusum_U_rando_crit(double A, double mu0, int km, int m, int i0, int *hm, double *gamma); double ccusum_L_arl(double mu, int km, int hm, int m, int i0); double ccusum_L_arl_rando(double mu, int km, int hm, int m, double gamma, int i0); int ccusum_L_crit(double A, double mu0, int km, int m, int i0); int ccusum_L_rando_crit(double A, double mu0, int km, int m, int i0, int *hm, double *gamma); double ccusum_2_arl(double mu, int km1, int hm1, int m1, int i01, int km2, int hm2, int m2, int i02); double ccusum_2_arl_rando(double mu, int km1, int hm1, int m1, double gamma1, int i01, int km2, int hm2, int m2, double gamma2, int i02); /* IMR combos */ double imr_arl_case01(double M, double R, double mu, double sigma, int N, int qm); double imr_arl_case02(double M, double R, double mu, double sigma, int N, int qm); double imr2_arl(double M, double Rl, double Ru, double mu, double sigma, int N, int qm); double imr2_arl_case03(double M, double Rl, double mu, double sigma, int N, int qm); /* tolerance intervals */ double kww(int n, double q, double a); double tl_factor(int n, double q, double a, int m); /* internal functions etc. */ int qm_for_l_and_c(double l, double c); int choose_N_for_seU(double lambda); int choose_N_for_se2(double lambda, double cl, double cu); void gausslegendre(int n, double x1, double x2, double *x, double *w); void radau(int n, double x1, double x2, double *x, double *w); int LU_decompose(double *a, int *ps, int n); void LU_solve(double *a, double *b, int n); void LU_solve2(double *a, double *b, int *ps, int n); void pmethod(int n, double *p, int *status, double *lambda, double x_[], int *noofit); int *ivector(long n); double *vector (long n); double *matrix(long m, long n); double phi(double x, double mu); double PHI(double x, double mu); double qPHI(double p); double chi(double s, int df); double CHI(double s, int df); double qCHI(double p, int df); double nchi(double s, int df, double ncp); double nCHI(double s, int df, double ncp); double nqCHI(double p, int df, double ncp); double pdf_t(double x, int df); double cdf_t(double x, int df); double qf_t(double x, int df); double pdf_tn(double x, int df, double ncp); double cdf_tn(double x, int df, double ncp); double qf_tn(double x, int df, double ncp); double cdf_binom(double q, int n, double p); double qf_binom(double q, int n, double p); double pdf_binom(double x, int n, double p); double cdf_pois(double q, double lambda); double qf_pois(double q, double lambda); double pdf_pois(double x, double lambda); double Tn(double z, int n); /* Chebyshev polynomials */ double iTn(double z, int n); /* indefinite integrals of Chebyshev polynomials */ double dTn(double z, int n); /* derivatives of Chebyshev polynomials */ double rho0; /* ------------------- functions and procedures ------------- */ int *ivector(long n) { return (int *) Calloc( n, int ); } double *vector(long n) { return (double *) Calloc( n, double ); } double *matrix(long m, long n) { return (double *) Calloc( m*n, double ); } /* normal density (pdf) */ double phi(double x, double mu) { return dnorm(x,mu,1.,LOG); } /* normal cumulative distribution function (cdf) */ double PHI(double x, double mu) { return pnorm(x,mu,1.,TAIL,LOG); } /* qf of normal rv */ double qPHI(double p) { return qnorm(p,0.,1.,TAIL,LOG); } /* pdf of chisquare rv */ double chi(double s, int df) { return dchisq(s,(double)df,LOG); } /* pdf of non-central chisquare rv */ double nchi(double s, int df, double ncp) { return dnchisq(s,(double)df,ncp,LOG); } /* cdf of chisquare rv */ double CHI(double s, int df) { return pchisq(s,(double)df,TAIL,LOG); } /* cdf of non-central chisquare rv */ double nCHI(double s, int df, double ncp) { return pnchisq(s,(double)df,ncp,TAIL,LOG); } /* qf of chisquare rv */ double qCHI(double p, int df) { return qchisq(p,(double)df,TAIL,LOG); } /* qf of non-central chisquare rv */ double nqCHI(double p, int df, double ncp) { return qnchisq(p,(double)df,ncp,TAIL,LOG); } /* pdf of t distribution */ double pdf_t(double x, int df) { return dt(x,(double)df,LOG); } /* cdf of t distribution */ double cdf_t(double x, int df) { return pt(x,(double)df,TAIL,LOG); } /* quantile function of t distribution */ double qf_t(double x, int df) { return qt(x,(double)df,TAIL,LOG); } /* pdf of non-central t distribution */ double pdf_tn(double x, int df, double ncp) { return dnt(x,(double)df,ncp,LOG); } /* cdf of non-central t distribution */ double cdf_tn(double x, int df, double ncp) { return pnt(x,(double)df,ncp,TAIL,LOG); } /* quantile function of non-central t distribution */ double qf_tn(double x, int df, double ncp) { return qnt(x,(double)df,ncp,TAIL,LOG); } /* cdf of binomial rv */ double cdf_binom(double q, int n, double p) { return pbinom(q,(double)n,p,TAIL,LOG); } /* qf of binomial rv */ double qf_binom(double q, int n, double p) { return qbinom(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); } /* cdf of Poisson rv */ double cdf_pois(double q, double lambda) { return ppois(q,lambda,TAIL,LOG); } /* qf of Poisson rv */ double qf_pois(double q, double lambda) { return qpois(q,lambda,TAIL,LOG); } /* pdf of Poisson rv */ double pdf_pois(double x, double lambda) { return dpois(x,lambda,LOG); } /* expectation of log-gamma */ double E_log_gamma(double ddf) { return log(2./ddf) + digamma(ddf/2.); } /* variance of log-gamma */ double V_log_gamma(double ddf) { return trigamma(ddf/2.); } /* expectation of S (chi) */ double c_four(double ddf) { return sqrt( 2./ddf ) * gammafn( (ddf+1)/2. ) / gammafn( ddf/2. ); } /* lapack routine */ void solve(int *n, double *a, double *b) { int nrhs=1, lda, ldb, *ipiv, info=0; lda = *n; ldb = *n; ipiv = ivector(*n); F77_NAME(dgesv)(n, &nrhs, a, &lda, ipiv, b, &ldb, &info); Free(ipiv); } /* abscissae and weights of Gauss-Legendre quadrature */ #define GLeps 3e-11 void gausslegendre(int n, double x1, double x2, double *x, double *w) /* The following algorithm is based on ideas of Knut Petras (see http://www-public.tu-bs.de:8080/~petras/). The nodes are derived by means of the Newton method. Afterwards, the weights are obtained by utilizing (regarding the connection between the Christoffel function and the weight, which is also called Christoffel number) w_i = w(x_i) = 2 / sum_j=0^n ( (2j+1) * (P_j(x_i))^2 ) which is more stable than to rely on the usual w_i = 2 / (1-x_i^2)/(P_n^'(x_i))^2. Note that the Newton method is stopped as soon as the distance between two successive iterates is smaller than GLeps, plus one extra step. By comparing with results in Yakimiw (1996) we may conclude that the code behaves very well and even better. */ { double xw, xmid, z0, z1, diff, p0, p1, p2=0., a; int i, j, m, stop, odd; m = (n+1)/2; odd = n%2 == 1; xmid = .5*(x2+x1); /* interval centre */ xw = .5*(x2-x1); /* half interval length */ for (i=0;i kind of overiterating) */ } x[i] = xmid + xw*z1; x[n-1-i] = xmid - xw*z1; /* nodes on interval (x1,x2) */ p0 = 1.; p1 = z1; a = 1. + 3.*z1*z1; for (j=1;jfabs(newmu) ) { newmu = y_[i]; newi = i; } for (i=0;i 1e-10 ) arl = ( exp(-2.*Delta*b) + 2.*Delta*b - 1. )/2./Delta/Delta; else arl = b*b; return arl; } double BM_xc_crit(double k, double L0, double m0) { double c1, c2, c3, L1=0., L2=0., L3=0., dc; c2 = 0.; do { c2 += .1; L2 = BM_xc_arl(k, c2, m0); } while ( L2 1e-10 ) { c3 = c1 + (L0-L1)/(L2-L1) * (c2-c1); L3 = BM_xc_arl(k, c3, m0); dc = c3-c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3; } else { dc = 1e-12; c3 = c2; } } while ( (fabs(L0-L3)>1e-6) && (fabs(dc)>1e-9) ); return c3; } /* ************************************************************************* */ /* zero-state and steady-state ARl and critical value routines */ double xc_crit(int ctyp, double k, double L0, double hs, double m0, int N) { double c1, c2, c3, L1=0., L2=0., L3=0., dc, k_bm; if ( ctyp==cusumC || fabs(hs)>1e-9 ) { c2 = 0.; do { c2 += .5; if (ctyp==cusum1) L2 = xc1_iglarl ( k,c2,hs,m0,N ); if (ctyp==cusum2) L2 = xc2_iglarl ( k,c2,hs,m0,N ); if (ctyp==cusumC) L2 = xcC_iglarl ( k,c2,hs,m0,N ); } while (L21e-6) && (fabs(dc)>1e-9) ); return c3; } double xsr1_crit(double k, double L0, double zr, double hs, double m0, int N, int MPT) { double c1, c2, c3, L1, L2, L3, dc; c2 = 0.; do { c2 += .5; L2 = xsr1_iglarl(k, c2, zr, hs, m0, N, MPT); /*printf("c2 = %.2f,\tL2 = %.6f\n", c2, L2);*/ } while ( L2L0 ); c1 = c2 + 0.05; L1 = xsr1_iglarl(k, c1, zr, hs, m0, N, MPT); do { c3 = c1 + (L0-L1)/(L2-L1) * (c2-c1); L3 = xsr1_iglarl(k, c3, zr, hs, m0, N, MPT); /*printf("c3 = %.2f,\tL3 = %.6f\n", c3, L3);*/ dc = c3-c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3; } while ( (fabs(L0-L3)>1e-6) && (fabs(dc)>1e-9) ); return c3; } double xe_crit(int ctyp, double l, double L0, double zr, double hs, double m0, int ltyp, int N, double c0) { double c1, c2, c3, L1=0., L2=0., L3=0., dc, norm, L2old=0., c2old=0.; int nmax=100000; if ( (ctyp==ewma1 && c0 < zr) || (ctyp==ewma2 && c0 < 0.) ) c2 = hs+1.; else c2 = c0; do { if ( ctyp==ewma1 ) { if ( ltyp==fix && hs>=0. ) L2 = xe1_iglarl ( l,c2,zr,hs,m0,N ); if ( ltyp==fix && hs<0. ) L2 = xe1_iglarl ( l,c2,zr,c2/2,m0,N ); if ( ltyp>fix ) L2 = xe1_arlm ( l,c2,zr,hs,1,m0,m0,ltyp,N,nmax ); } if ( ctyp==ewma2 ) { if ( ltyp==fix ) L2 = xe2_iglarl ( l,c2,hs,m0,N ); if ( ltyp>fix ) { if ( hs<0. && ltyp==fir ) L2 = xe2_arlm ( l,c2,c2/2.,1,m0,m0,ltyp,N,nmax ); if ( hs<0. && ltyp==both ) L2 = xe2_arlm ( l,c2,c2/2.*sqrt(l*(2.-l)),1,m0,m0,ltyp,N,nmax ); if ( hs>=0. ) L2 = xe2_arlm ( l,c2,hs,1,m0,m0,ltyp,N,nmax ); } } if ( L2 < 1. ) c2 -= .1; } while ( L2 < 1. && c2 > .00001 ); if ( L2 < 1. ) error("invalid ARL value"); if ( L2 > L0 ) { norm = -.1; } else { norm = .5; } if ( L2 < 1. + 1e-12 ) { c2 = 0.; norm = .1; } if ( (ctyp==ewma1 && c0 > zr) || (ctyp==ewma2 && c0 > 0.) ) norm /= 10.; do { L2old = L2; c2old = c2; c2 += norm; do { if ( ctyp==ewma1 ) { if ( ltyp==fix && hs>=0. ) L2 = xe1_iglarl ( l,c2,zr,hs,m0,N ); if ( ltyp==fix && hs<0. ) L2 = xe1_iglarl ( l,c2,zr,c2/2,m0,N ); if ( ltyp>fix ) L2 = xe1_arlm ( l,c2,zr,hs,1,m0,m0,ltyp,N,nmax ); } if ( ctyp==ewma2 ) { if ( ltyp==fix ) L2 = xe2_iglarl ( l,c2,hs,m0,N ); if ( ltyp>fix ) { if ( hs<0. && ltyp==fir ) L2 = xe2_arlm ( l,c2,c2/2.,1,m0,m0,ltyp,N,nmax ); if ( hs<0. && ltyp==both ) L2 = xe2_arlm ( l,c2,c2/2.*sqrt(l*(2.-l)),1,m0,m0,ltyp,N,nmax ); if ( hs>=0. ) L2 = xe2_arlm ( l,c2,hs,1,m0,m0,ltyp,N,nmax ); } } if ( L2 < 1. ) { norm /= 2.; c2 -= norm; } if ( c2 <= 1e-9 && fabs(L2-L2old)>100. ) norm = -.001; } while ( L2 < 1. ); } while ( ((L2 < L0 && norm>0.) || (L2 > L0 && norm<0.)) && (fabs(norm)>1e-8) ); c1 = c2old; L1 = L2old; do { c3 = c1 + (L0-L1)/(L2-L1) * (c2-c1); norm = .5; do { if ( ctyp==ewma1 ){ if ( ltyp==fix && hs>=0. ) L3 = xe1_iglarl ( l,c3,zr,hs,m0,N ); if ( ltyp==fix && hs<0. ) L3 = xe1_iglarl ( l,c3,zr,c3/2,m0,N ); if ( ltyp>fix ) L3 = xe1_arlm ( l,c3,zr,hs,1,m0,m0,ltyp,N,nmax ); } if ( ctyp==ewma2 ) { if ( ltyp==fix ) L3 = xe2_iglarl ( l,c3,hs,m0,N ); if ( ltyp>fix ) { if ( hs<0. && ltyp==fir ) L3 = xe2_arlm ( l,c3,c3/2.,1,m0,m0,ltyp,N,nmax ); if ( hs<0. && ltyp==both ) L3 = xe2_arlm ( l,c3,c3/2.*sqrt(l*(2.-l)),1,m0,m0,ltyp,N,nmax ); if ( hs>=0. ) L3 = xe2_arlm ( l,c3,hs,1,m0,m0,ltyp,N,nmax ); } } if ( L3 < 1. ) { c3 = c1 + norm*(L0-L1)/(L2-L1) * (c2-c1); norm /= 2.; } } while ( (L3 < 1.) && (fabs(norm)>1e-8) ); dc = c3-c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3; if ( L3 < 1. ) error("invalid ARL value"); } while ( (fabs(L0-L3)>1e-6) && (fabs(dc)>1e-9) ); if ( fabs(L0-L3)>1e-6 ) warning("did not converge"); return c3; } double xe_q_crit(int ctyp, double l, int L0, double alpha, double zr, double hs, double m0, int ltyp, int N, double c_error, double a_error) { double c1=0., c2=0., c3=0., p1=1., p2=1., p3=1., dc, *SF; int result=1; SF = vector(L0); c2 = 0.; p2 = 1.; do { p1 = p2; c2 += .5; if ( ctyp==ewma1 && ltyp==fix ) result = xe1_sf(l, c2, zr, hs, m0, N, L0, SF); if ( ctyp==ewma1 && ltyp>fix ) error("not implemented yet for one-sided EWMA and varying limits"); if ( ctyp==ewma2 && ltyp==fix ) result = xe2_sf(l, c2, hs, m0, N, L0, SF); if ( ctyp==ewma2 && ltyp>fix ) result = xe2_sfm(l, c2, hs, 1, m0, m0, ltyp, N, L0, SF); if ( result != 0 ) warning("trouble in xe_q_crit [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha ); c1 = c2 - .5; do { c3 = c1 + ( alpha - p1 )/( p2 - p1 ) * ( c2 - c1 ); if ( ctyp==ewma1 && ltyp==fix ) result = xe1_sf(l, c3, zr, hs, m0, N, L0, SF); if ( ctyp==ewma1 && ltyp>fix ) error("not implemented yet for one-sided EWMA and varying limits"); if ( ctyp==ewma2 && ltyp==fix ) result = xe2_sf(l, c3, hs, m0, N, L0, SF); if ( ctyp==ewma2 && ltyp>fix ) result = xe2_sfm(l, c3, hs, 1, m0, m0, ltyp, N, L0, SF); if ( result != 0 ) warning("trouble in xe_q_crit [package spc]"); p3 = 1. - SF[L0-1]; dc = c3 - c2; c1 = c2; p1 = p2; c2 = c3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(dc)>c_error ); Free(SF); return c3; } double xc1_iglarl(double k, double h, double hs, double mu, int N) { double *a, *g, *w, *z, arl; int i, j, NN; NN = N + 1; a = matrix(NN,NN); g = vector(NN); w = vector(N); z = vector(N); gausslegendre(N,0.,h,z,w); for (i=0;i1 ) { for (i=0; imn_plus ) mn_plus = ratio; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(p0); Free(Pn); Free(z); Free(w); Free(atom); return Wq; } double xc1_sf(double k, double h, double hs, double mu, int N, int nmax, double *p0) { double *Pn, *w, *z, *atom; int i, j, n; w = vector(N); z = vector(N); Pn = matrix(nmax,N); atom = vector(nmax); gausslegendre(N,0,h,z,w); for (n=1;n<=nmax;n++) { if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { /* determine f_n, n=q,q+1,... */ if (n==1) { for (i=0;i1) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI(k, mu1); for (j=0;j1) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2.; rho0 = rho; Free(w); Free(z); Free(fn); Free(p0); return arl; } double xc1_arlm_hom(double k, double h, double hs, int q, double mu0, double mu1, int N, double *ced) { double *fn, *w, *z, *a, *arl, norm; int i, j, n, NN; NN = N + 1; w = vector(NN); z = vector(NN); fn = matrix(q+1, NN); a = matrix(NN,NN); arl = vector(NN); gausslegendre(N, 0., h, z, w); /* ARL vector */ for (i=0; i 1 */ for (n=1; n<=q-1; n++) { if (n==1) { for (i=0; ieps && (double)m_<1e4 ) { m_ = (int)round(1.5 * m_); arl1 = xc1_iglarl_drift(k, h, hs, delta, m_, N, with0); arl2 = xc1_iglarl_drift(k, h, hs, delta, m_+1, N, with0); } *m = m_; return arl1; } double xc1_iglarlm_drift(double k, double h, double hs, int q, double delta, int N, int nmax, int with0) { double *p0, *fn, *w, *z, arl0, rho, MEAN=0., arl_minus=0., arl, arl_plus=0., mn_minus=0., mn_plus=0., nn, ratio=0.; int i, j, n, NN; NN = N + 1; w = vector(NN); z = vector(NN); fn = matrix(nmax, NN); p0 = vector(nmax); gausslegendre(N, 0, h, z, w); /* in-control, i. e. n<=q-1 */ MEAN = 0.; for (n=1;n<=q-1;n++) { nn = (double) n; /* determine f_n, n=1,2,...,q-1 */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine f_n, n=q,q+1,... */ if ( with0 ) { MEAN = (nn-(double)q) * delta; } else { MEAN = (nn-(double)q+1.) * delta; } if (n==1) { for (i=0;i1) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI(k, MEAN); for (j=0;j1) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2.; rho0 = rho; Free(w); Free(z); Free(fn); Free(p0); return arl; } double xc2_iglarl(double k, double h, double hs, double mu, int N) { double arl1, arl2, arl3, arl4, arl; /* relation between 1- and 2-sided CUSUM schemes due to Lucas/Crosier 1982, Technometrics 24, 199-205; only for headstart hs smaller than h/2 + k !! */ arl1 = xc1_iglarl(k,h,0.,mu,N); arl2 = xc1_iglarl(k,h,hs,mu,N); arl3 = xc1_iglarl(k,h,0.,-mu,N); arl4 = xc1_iglarl(k,h,hs,-mu,N); arl = ( arl2*arl3 + arl1*arl4 - arl1*arl3 ) / ( arl1 + arl3 ); return arl; } double xtc2_iglarl(double k, double h, double hs, int df, double mu, int N, int subst) { double arl1, arl2, arl3, arl4, arl; /* relation between 1- and 2-sided CUSUM schemes due to Lucas/Crosier 1982, Technometrics 24, 199-205; only for headstart hs smaller than h/2 + k !! */ arl1 = xtc1_iglarl(k, h, 0., df, mu, N, subst); arl2 = xtc1_iglarl(k, h, hs, df, mu, N, subst); arl3 = xtc1_iglarl(k, h, 0., df, -mu, N, subst); arl4 = xtc1_iglarl(k, h, hs, df, -mu, N, subst); arl = ( arl2*arl3 + arl1*arl4 - arl1*arl3 ) / ( arl1 + arl3 ); return arl; } double xc2_be_arl (double k, double h, double hs1, double hs2, double mu, int N) { double *a, *g, arl, z1, z2, z11, z12, z21, z22, w; int i1, i2, j1, j2, NN, N3; /* two-dimensional Markov chain approximation */ NN = N*N; N3 = NN*N; a = matrix(NN,NN); g = vector(NN); w = 2.*h/(2.*N - 1.); for (i1=0;i1 z2 ) a[i1*N3+j1*NN+i2*N+j2] = 0.; else a[i1*N3+j1*NN+i2*N+j2] = -PHI(z2, mu) + PHI(z1, mu); if ( i1==i2 && j1==j2 ) a[i1*N3+j1*NN+i2*N+j2]++; } for (j1=0;j1eps && (double)m_<1e4 ) { m_ = (int)round(1.5 * m_); arl1 = xc2_iglarl_drift(k, h, hs, delta, m_, N, drift0); arl2 = xc2_iglarl_drift(k, h, hs, delta, m_+1, N, drift0); } *m = m_; return arl1; } double xcC_iglarl (double k, double h, double hs, double mu, int N) { double *a, *g, *w, *z, arl; int i, j, NN; NN = 2*N + 1; a = matrix(NN,NN); g = vector(NN); w = vector(NN); z = vector(NN); gausslegendre(N,0.,h,z,w); for (i=0;ib[ii-1] ) xl = za; else xl = b[ii-1]; xu = b[ii]; if ( df!=2 && b[ii]>za ) { xl = sqrt(xl-za); xu = sqrt(xu-za); } for (jj=1; jj<=Ntilde; jj++) { qj = (ii-1)*Ntilde + jj-1; if ( b[ii] hs ) { ihs = i-1; i = M+1; } } /* Chebyshev nodes on [b_1,b_2],[b_2,b_3],...,[b_M,hu] */ for (i=1; i<=M; i++) for (j=1; j<=Ntilde; j++) zch[(i-1)*Ntilde + j-1] = b[i-1] + (b[i]-b[i-1])/2.*(1.+cos(PI*(2.*(Ntilde-j+1.)-1.)/2./dN)); for (i=1; i<=M; i++) for (j=1; j<=Ntilde ;j++) { qi = (i-1)*Ntilde + j-1; za = zch[(i-1)*Ntilde + j-1] - refk; zb = zch[(i-1)*Ntilde + j-1] + eps; for (ii=1; ii<=M; ii++) { if ( za>b[ii-1] ) xl = za; else xl = b[ii-1]; if ( zbza ) { xl = sqrt(xl-za); xu = sqrt(xu-za); } for (jj=1; jj<=Ntilde; jj++) { qj = (ii-1)*Ntilde + jj-1; if ( xuh ) t1 = h; for (j=1; j1 ) { ii = i-1; t0 = (double)(ii-1.)*refk; t1 = t0 + refk; if ( t1>h ) t1 = h; if ( t01e-10 ) x0 = sqrt(x0-za); else x0 = 0.; if ( t1-za>1e-10 ) x1 = sqrt(t1-za); else x1 = 0.; } else x1 = t1; for (jj=1; jj<=Ntilde; jj++) { qj = (ii-1)*Ntilde + jj-1; if ( j==1 ) a[qi*NN + qj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),jj-1); else { if ( fabs(x1-x0)>1e-12 ) { gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; k 1 */ for (ii=i; ii<=M; ii++) { t0 = (double)(ii-1.)*refk; t1 = t0 + refk; if ( t1>h ) t1 = h; if ( t01e-10 ) x0 = sqrt(x0-za); else x0 = 0.; if ( t1-za>1e-10 ) x1 = sqrt(t1-za); else x1 = 0.; } else x1 = t1; if ( i>1 && j==1 && ii==i ) { for (jj=1; jj<=Ntilde; jj++) { qj = (ii-1)*Ntilde + jj-1; a[qi*NN + qj] = Tn((2.*t[it]-t0-t1)/(t1-t0),jj-1); } /* jj = 1 .. Ntilde */ } /* i>1 && j==1 && ii==i */ if ( i>1 && j==1 && ii>i ) { for (jj=1; jj<=Ntilde; jj++) { qj = (ii-1)*Ntilde + jj-1; a[qi*NN + qj] = 0.; } /* jj = 1 .. Ntilde */ } /* i>1 && j==1 && ii>i */ if ( i==1 || j>1 ) { for (jj=1; jj<=Ntilde; jj++) { qj = (ii-1)*Ntilde + jj-1; gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; k1 */ } /* ii = i .. M */ if ( i==1 ) { t0 = 0.; t1 = refk; if ( t1>h ) t1 = h; for (jj=1; jj<=Ntilde; jj++) { dummy = -za/s2; if ( dummy>0. ) { if ( df==1 ) dummy = 2.*PHI( sqrt(dummy), 0. ) - 1.; if ( df==2 ) dummy = 1. - exp( -dummy ); if ( df>2 ) dummy = CHI( ddf*dummy, df); } else dummy = 0.; a[qi*NN + jj-1] -= dummy * Tn(-1.,jj-1); } /* jj = 1 .. Ntilde */ } /* i==1 */ } /* i = 1 .. M, j = 1 .. Ntilde */ for (j=0; jh ) t1 = h; if ( t0<=hs && hsM ) imax = M; for (ii=1; ii<=imax; ii++) { t0 = h - (double)(M-ii+1.)*refk; t1 = t0 + refk; if ( t0<0. ) t0 = 0.; if ( t11e-10 ) x0 = sqrt(za-x1); else x0 = 0.; if ( za-t0>1e-10 ) x1 = sqrt(za-t0); else x1 = 0.; } else x0 = t0; for (jj=1; jj<=Ntilde; jj++) { qj = (ii-1)*Ntilde + jj-1; if ( i>1 && j==1 ) { /* continuity condition */ if ( ii==i-1 ) a[qi*NN + qj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),jj-1); if ( ii==i ) a[qi*NN + qj] = Tn((2.*t[it]-t0-t1)/(t1-t0),jj-1); if ( iii) a[qi*NN + qj] = 0.; } else { gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; k1 && j==1) */ } /* jj = 1 .. Ntilde */ } /* ii = 1 .. imax <= M */ for (ii=i+2; ii<=M; ii++) for (jj=1; jj<=Ntilde; jj++) { qj = (ii-1)*N + jj-1; a[qi*NN + qj] = 0.; } if ( i==1 || j>1 ) { for ( jj=1; jj<=Ntilde; jj++) { /* ii = 1 -- atom */ dummy = za/s2; if ( df==1 ) dummy = 2.*( 1. - PHI( sqrt(dummy), 0. ) ); if ( df==2 ) dummy = exp( -dummy ); if ( df>2 ) dummy = 1. - CHI( ddf*dummy, df); a[qi*NN + jj-1] -= dummy * Tn(-1.,jj-1); } /* jj = 1 .. Ntilde */ } /* i==1 || j>1 */ } /* i = 1 .. M, j = 1 .. Ntilde */ for (j=0; j1e-6) && (fabs(dc)>1e-9) ); return c3; } double scL_crit(double refk, double L0, double hs, double sigma, int df, int N, int qm) { double c1, c2, c3, L1=0., L2=0., L3=0., dc; c2 = 0.; L2 = 1.; do { c1 = c2; L1 = L2; c2 += 1; L2 = scL_iglarl_v2(refk, c2, hs, sigma, df, N, qm); } while ( L21e-6) && (fabs(dc)>1e-9) ); return c3; } double scL_fu_crit(double refkl, double refku, double hu, double L0, double hsl, double hsu, double sigma, int df, int N, int qm) { double c1, c2, c3, L1=0., L2=0., L3=0., dc; c2 = 0.; L2 = 1.; do { c1 = c2; L1 = L2; c2 += 1; L2 = sc2_iglarl_v2(refkl, refku, c2, hu, hsl, hsu, sigma, df, N, qm); } while ( L21e-6) && (fabs(dc)>1e-9) ); return c3; } double scU_fl_crit(double refkl, double refku, double hl, double L0, double hsl, double hsu, double sigma, int df, int N, int qm) { double c1, c2, c3, L1=0., L2=0., L3=0., dc; c2 = 0.; L2 = 1.; do { c1 = c2; L1 = L2; c2 += 1; L2 = sc2_iglarl_v2(refkl, refku, hl, c2, hsl, hsu, sigma, df, N, qm); } while ( L21e-6) && (fabs(dc)>1e-9) ); return c3; } int sc2_crit_unbiased(double refkl, double refku, double L0, double *hl, double *hu, double hsl, double hsu, double sigma, int df, int N, int qm) { double h1, h2, h3, dh, lh, sl1, sl2, sl3, Lm, Lp, step; step = .2/sqrt(df); h1 = scU_crit(refku, 2.*L0, hsu, sigma, df, N, qm); lh = scL_crit(refkl, 2.*L0, hsl, sigma, df, N, qm); Lm = sc2_iglarl_v2(refkl, refku, lh, h1, hsl, hsu, sigma-lmEPS, df, N, qm); Lp = sc2_iglarl_v2(refkl, refku, lh, h1, hsl, hsu, sigma+lmEPS, df, N, qm); sl1 = (Lp-Lm)/(2.*lmEPS); h2 = h1; sl2 = sl1; do { h1 = h2; sl1 = sl2; h2 = h1 + step; lh = scL_fu_crit(refkl, refku, h2, L0, hsl, hsu, sigma, df, N, qm); Lm = sc2_iglarl_v2(refkl, refku, lh, h2, hsl, hsu, sigma-lmEPS, df, N, qm); Lp = sc2_iglarl_v2(refkl, refku, lh, h2, hsl, hsu, sigma+lmEPS, df, N, qm); sl2 = (Lp-Lm)/(2.*lmEPS); } while ( sl2 < 0. ); do { h3 = h1 - sl1/(sl2-sl1) * (h2-h1); lh = scL_fu_crit(refkl, refku, h3, L0, hsl, hsu, sigma, df, N, qm); Lm = sc2_iglarl_v2(refkl, refku, lh, h3, hsl, hsu, sigma-lmEPS, df, N, qm); Lp = sc2_iglarl_v2(refkl, refku, lh, h3, hsl, hsu, sigma+lmEPS, df, N, qm); sl3 = (Lp-Lm)/(2.*lmEPS); dh = h3-h2; h1 = h2; sl1 = sl2; h2 = h3; sl2 = sl3; } while ( fabs(sl3)>1e-7 && fabs(dh)>1e-9 ); *hl = lh; *hu = h3; return 0; } /* MPT = Moustakides/Polunchenko/Tartakovsky */ double xsr1_iglarl(double k, double h, double zr, double hs, double mu, int N, int MPT) { double *a, *g, *w, *z, arl, adjust=1.; int i, j, NN; adjust = 1.; if ( MPT ) adjust = 2.*k; NN = N + 1; a = matrix(NN,NN); g = vector(NN); w = vector(NN); z = vector(NN); gausslegendre(N, zr, h, z, w); for (i=0;i h) {*/ if ( hs > 10.*h ) { arl = 1. + PHI( zr/adjust + k, mu) * g[N]; for (j=0;j h ) { for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0; i=q */ arl0 = 1.; rho = 0.; for (n=q; n<=nmax; n++) { if ( n==1 ) { if ( hs > h ) { for (i=0; i1 ) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (zr-log(1.+exp(zr)))/adjust + k, mu1); for (j=0; j1 ) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i q ) { for (i=0; imn_plus ) mn_plus = ratio; } rho = p0[n-1]/p0[n-2]; } /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2.; rho0 = rho; Free(w); Free(z); Free(fn); Free(p0); return arl; } double xsr1_arlm_hom(double k, double h, double zr, double hs, int q, double mu0, double mu1, int N, int MPT, double *ced) { double *fn, *w, *z, *a, *arl, adjust=1., norm; int i, j, n, NN; adjust = 1.; if ( MPT ) adjust = 2.*k; NN = N + 1; w = vector(NN); z = vector(NN); fn = matrix(q+1, NN); a = matrix(NN,NN); arl = vector(NN); gausslegendre(N, zr, h, z, w); /* ARL vector */ for (i=0; i h ) { ced[0] = 1. + PHI( zr/adjust + k, mu1) * arl[N]; for (j=0; j 1 */ for (n=1; n<=q-1; n++) { if ( n == 1 ) { if ( hs > h ) { for (i=0; i h) { arl = 1. + PHI( zr+k, MUs[0]) * ARLs[N]; for (j=0;jeps && (double)m_<1e4 ) { m_ = (int)round(1.5 * m_); arl1 = xsr1_iglarl_drift(k, h, zr, hs, delta, m_, N, with0); arl2 = xsr1_iglarl_drift(k, h, zr, hs, delta, m_+1, N, with0); } *m = m_; return arl1; } double xsr1_iglarlm_drift(double k, double h, double zr, double hs, int q, double delta, int N, int nmax, int with0) { double *p0, *fn, *w, *z, arl0, rho, MEAN=0., arl_minus=0., arl, arl_plus=0., mn_minus=0., mn_plus=0., nn, ratio=0.; int i, j, n, NN; NN = N + 1; w = vector(NN); z = vector(NN); fn = matrix(nmax, NN); p0 = vector(nmax); gausslegendre(N, zr, h, z, w); /* in-control, i. e. n<=q-1 */ MEAN = 0.; for (n=1;n<=q-1;n++) { nn = (double) n; /* determine f_n, n=1,2,...,q-1 */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine f_n, n=q,q+1,... */ if ( with0 ) { MEAN = (nn-(double)q) * delta; } else { MEAN = (nn-(double)q+1.) * delta; } if (n==1) { for (i=0;i1) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( zr-log(1.+exp(zr))+k, MEAN); for (j=0;j1) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2.; rho0 = rho; Free(w); Free(z); Free(fn); Free(p0); return arl; } double xsr1_iglad(double k, double h, double zr, double mu0, double mu1, int N, int MPT) { double *a, *w, *z, *arl, *psi, rho, ad, norm, adjust=1.; int i, j, status, noofit, NN; adjust = 1.; if ( MPT ) adjust = 2.*k; NN = N + 1; a = matrix(NN,NN); arl = vector(NN); psi = vector(NN); w = vector(NN); z = vector(NN); gausslegendre(N, zr, h, z, w); for (i=0; i 1. && fabs(mu) > 1. ) arl = PHI(w,0.)/phi(w,0.)/l/w; return arl; } double xe2_SrWu_arl_full(double l, double c, double mu) { double eta, Lmu, alpha1, alpha2, h1, h2, f1, f2, arl=-1., *w, *z; int i, qm=50; mu = fabs(mu); w = vector(qm); z = vector(qm); Lmu = c + 1.16*sqrt(l*mu); eta = mu * sqrt(2./l); gausslegendre(qm, 0, Lmu, z, w); alpha1 = 0.; alpha2 = 0.; for (i=0; i= -c ) { z1 = asin(zr/c); z2 = PI/2.; norm=c; } else { z1 = -PI/2.; z2 = asin(c/fabs(zr)); norm=fabs(zr); } break; case SINH: if ( zr >= -c ) { z1 = asinh(zr/c); z2 = asinh(1.); norm=c; } else { z1 = asinh(-1.); z2 = asinh(c/fabs(zr)); norm=fabs(zr); } break; case TAN: if ( zr >= -c ) { z1 = atan(zr/c); z2 = PI/4.; norm=c; } else { z1 = -PI/4.; z2 = atan(c/fabs(zr)); norm=fabs(zr); } break; } gausslegendre(N, z1, z2, z, w); for (i=0; ieps && (double)m_<1e4 ) { m_ = (int)round(1.5 * m_); arl1 = xe1_iglarl_drift(l, c, zr, hs, delta, m_, N, with0); arl2 = xe1_iglarl_drift(l, c, zr, hs, delta, m_+1, N, with0); } *m = m_; return arl1; } double xe1_iglarlm_drift(double l, double c, double zr, double hs, int q, double delta, int N, int nmax, int with0) { double *p0, *fn, *w, *z, arl0, rho, MEAN=0., arl_minus=0., arl, arl_plus=0., mn_minus=0., mn_plus=0., nn, ratio=0.; int i, j, n, NN; NN = N + 1; w = vector(NN); z = vector(NN); fn = matrix(nmax, NN); p0 = vector(nmax); c *= sqrt( l/(2.-l) ); zr *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); gausslegendre(N, zr, c, z, w); /* in-control, i. e. n<=q-1 */ MEAN = 0.; for (n=1;n<=q-1;n++) { nn = (double) n; /* determine f_n, n=1,2,...,q-1 */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine f_n, n=q,q+1,... */ if ( with0 ) { MEAN = (nn-(double)q) * delta; } else { MEAN = (nn-(double)q+1.) * delta; } if (n==1) { for (i=0;i1) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( zr, MEAN); for (j=0;j1) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2.; rho0 = rho; Free(w); Free(z); Free(fn); Free(p0); return arl; } double xe2_iglarl_drift(double l, double c, double hs, double delta, int m, int N, int with0) { double *a, *g, *w, *z, arl, *MUs, *ARLs; int i, j, m_; a = matrix(N,N); g = vector(N); w = vector(N); z = vector(N); ARLs = vector(N); MUs = vector(m+1); c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); gausslegendre(N, -c, c, z, w); if ( with0 ) { for (i=0;i<=m;i++) MUs[i] = (double)i * delta; } else { for (i=0;i<=m;i++) MUs[i] = (double)(i+1.) * delta; } for (i=0;ieps && (double)m_<1e4 ) { m_ = (int)round(1.5 * m_); arl1 = xe2_iglarl_drift(l, c, hs, delta, m_, N, with0); arl2 = xe2_iglarl_drift(l, c, hs, delta, m_+1, N, with0); } *m = m_; return arl1; } double xe2_iglarlm_drift(double l, double c, double hs, int q, double delta, int N, int nmax, int with0) { double *p0, *fn, *w, *z, arl0, rho, MEAN=0., arl_minus=0., arl, arl_plus=0., mn_minus=0., mn_plus=0., nn, ratio=0.; int i, j, n; w = vector(N); z = vector(N); fn = matrix(nmax, N); p0 = vector(nmax); c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); gausslegendre(N, -c, c, z, w); /* in-control, i. e. n<=q-1 */ MEAN = 0.; for (n=1;n<=q-1;n++) { nn = (double) n; /* determine f_n, n=1,2,...,q-1 */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine f_n, n=q,q+1,... */ if ( with0 ) { MEAN = (nn-(double)q) * delta; } else { MEAN = (nn-(double)q+1.) * delta; } if (n==1) { for (i=0;i1) fn[(n-1)*N+i] /= p0[q-2]; } } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -2.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2.; rho0 = rho; Free(w); Free(z); Free(fn); Free(p0); return arl; } double xe2_Warl_drift(double l, double c, double hs, double delta, int N, int nmax, int with0) { double *Pn, *w, *z, *p0, MEAN, nn, ratio, arl_minus=0., arl0=1., arl_plus=0., mn_minus=1., mn_plus=0.; int i, j, n; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); w = vector(N); z = vector(N); Pn = matrix(nmax,N); p0 = vector(nmax); gausslegendre(N,-c,c,z,w); arl0 = 1.; for (n=1;n<=nmax;n++) { nn = (double)n; if ( with0 ) { MEAN = (nn-1.) * delta; } else { MEAN = nn * delta; } if (n==1) for (i=0;i1) { for (i=0;imn_plus ) mn_plus = ratio; } } if (0.1) { for (i=0;imn_plus ) mn_plus = ratio; } arl_minus = arl + p0[n-1]/(1.-mn_minus); arl_plus = arl + p0[n-1]/(1.-mn_plus); } arl += p0[n-1]; if ( fabs( (arl_plus-arl_minus)/arl_minus )1 ) { for (i=0; imn_plus ) mn_plus = ratio; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(p0); Free(Pn); Free(z); Free(w); Free(Sm); return Wq; } double xte2_Wq(double l, double c, double p, double hs, int df, double mu, int N, int nmax, int subst) { double *Sm, *Pn, *w, *z, *p0, ratio, q_minus=0., q_plus=0., mn_minus=1., mn_plus=0., enumerator=0., Wq=0., norm=1., arg=0., korr=1.; int i, j, n; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); Sm = matrix(N, N); w = vector(N); z = vector(N); Pn = matrix(nmax, N); p0 = vector(nmax); switch ( subst ) { case IDENTITY: gausslegendre(N, -c, c, z, w); norm = 1.; break; case SIN: gausslegendre(N, -PI/2., PI/2., z, w); norm = 1.; break; case SINH: gausslegendre(N, -1., 1., z, w); norm = sinh(1.); break; case TAN: gausslegendre(N, -PI/4., PI/4., z, w); norm = 1.; break; } c /= norm; for (i=0; i1 ) { for (i=0; imn_plus ) mn_plus = ratio; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(p0); Free(Pn); Free(z); Free(w); Free(Sm); return Wq; } double xe2_Wqm(double l, double c, double p, double hs, int q, double mu0, double mu1, int mode, int N, int nmax) { double *Smatrix, *p0, *fn, *w, *z, dn, rn, cn, rn0, cn0, delta=0., q_minus=2., q_plus=3., mn_minus, mn_plus, nn, fSt, aSt, ratio, enumerator=0., nq, Wq=0.; int i, j, n; fSt = 0.5; aSt = ( -2./log10(1.-fSt) - 1.)/19.; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); if ( mode==fir || mode==both ) delta = 2.*hs; Smatrix = matrix(N, N); w = vector(N); z = vector(N); fn = matrix(nmax, N); p0 = vector(nmax); gausslegendre(N, -c, c, z, w); rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.; /* in-control, i. e. n<=q-1 */ for (n=1; n<=q-1; n++) { nn = (double) n; /* determine c_n and r_n, n=1,2,...,q-1 */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=1,2,...,q-1 */ if ( n==1 ) { for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i=q */ for (n=q; n<=nmax; n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0; i1 ) fn[(n-1)*N+i] /= p0[q-2]; } } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i q ) { for (i=0; imn_plus ) mn_plus = ratio; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = nq + enumerator/log(mn_minus); q_plus = nq + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > q */ } /* p0[n-1] >= 1.-p */ } /* n=q; n<=nmax; n++ */ Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return Wq; } double xte2_Wqm(double l, double c, double p, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst) { double *Smatrix, *p0, *fn, *w, *z, dn, rn, cn, rn0, cn0, delta=0., q_minus=2., q_plus=3., mn_minus, mn_plus, nn, fSt, aSt, ratio, enumerator=0., nq, Wq=0., norm=1., arg=0., korr=1.; int i, j, n; fSt = 0.5; aSt = ( -2./log10(1.-fSt) - 1.)/19.; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); if ( mode==fir || mode==both ) delta = 2.*hs; Smatrix = matrix(N, N); w = vector(N); z = vector(N); fn = matrix(nmax, N); p0 = vector(nmax); switch ( subst ) { case IDENTITY: gausslegendre(N, -c, c, z, w); norm = 1.; break; case SIN: gausslegendre(N, -PI/2., PI/2., z, w); norm = 1.; break; case SINH: gausslegendre(N, -1., 1., z, w); norm = sinh(1.); break; case TAN: gausslegendre(N, -PI/4., PI/4., z, w); norm = 1.; break; } c /= norm; rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.; /* in-control, i. e. n<=q-1 */ for (n=1; n<=q-1; n++) { nn = (double) n; /* determine c_n and r_n, n=1,2,...,q-1 */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c*norm); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=1,2,...,q-1 */ if ( n==1 ) { for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i=q */ for (n=q; n<=nmax; n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c*norm); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0; i1 ) fn[(n-1)*N+i] /= p0[q-2]; } } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;i q ) { for (i=0; imn_plus ) mn_plus = ratio; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = nq + enumerator/log(mn_minus); q_plus = nq + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > q */ } /* p0[n-1] >= 1.-p */ } /* n=q; n<=nmax; n++ */ Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return Wq; } double xe1_Warl(double l, double c, double zr, double hs, double mu, int N, int nmax) { double *Pn, *w, *z, *p0, *atom, ratio, arl_minus=0., arl=1., arl_plus=0., mn_minus=1., mn_plus=0.; int i, j, n; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); zr *= sqrt( l/(2.-l) ); w = vector(N); z = vector(N); Pn = matrix(nmax,N); p0 = vector(nmax); atom = vector(nmax); gausslegendre(N,zr,c,z,w); for (n=1;n<=nmax;n++) { if (n==1) { for (i=0;i1) { mn_minus = atom[n-1]/atom[n-2]; mn_plus = atom[n-1]/atom[n-2]; for (i=0;imn_plus ) mn_plus = ratio; } arl_minus = arl + p0[n-1]/(1.-mn_minus); arl_plus = arl + p0[n-1]/(1.-mn_plus); } arl += p0[n-1]; if ( fabs( (arl_plus-arl_minus)/arl_minus )1 ) { mn_minus = atom[n-1]/atom[n-2]; mn_plus = atom[n-1]/atom[n-2]; for (i=0;imn_plus ) mn_plus = ratio; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(p0); Free(Pn); Free(z); Free(w); Free(atom); return Wq; } double xe1_Wqm(double l, double c, double p, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax) { double *Smatrix, *p0, *fn, *w, *z, rn, cn, rn0, cn0, q_minus=2., q_plus=3., mn_minus, mn_plus, nn, ratio, enumerator=0., nq, Wq=0.; int i, j, n, NN; c *= sqrt( l/(2.-l) ); zr *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); NN = N + 1; Smatrix = matrix(NN, NN); w = vector(NN); z = vector(NN); fn = matrix(nmax, NN); p0 = vector(nmax); gausslegendre(N, zr, c, z, w); rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.; /* in-control, i. e. n<=q-1 */ for (n=1;n<=q-1;n++) { nn = (double) n; /* determine r_n, n=1,2,...,q-1 */ if ( mode==vacl ) { rn = sqrt( 1. - pow(1.-l, 2.*nn) ); } /* determine f_n, n=1,2,...,q-1 */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ for (n=q;n<=nmax;n++) { nn = (double) n; /* determine r_n, n=1,2,...,q-1 */ if ( mode==vacl ) { rn = sqrt( 1. - pow(1.-l, 2.*nn) ); } /* determine f_n, n=q,q+1,... */ if (n==1) { for (i=0;i1 ) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*zr))/l, mu1); for (j=0;j1) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i q ) { for (i=0;imn_plus ) mn_plus = ratio; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = nq + enumerator/log(mn_minus); q_plus = nq + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > q */ } /* p0[n-1] >= 1.-p */ } /* n=q; n<=nmax; n++ */ Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return Wq; } double xe2_Carl(double l, double c, double hs, double mu, int N, int qm) { double *a, *g, *w, *z, arl, Hij, zi, lzi, dN; int i, j, k; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); dN = (double)N; a = matrix(N,N); g = vector(N); w = vector(qm); z = vector(qm); gausslegendre(qm,-c,c,z,w); for (i=0;i1)(zch[i]) */ for (i=0;i1) { for (i=0;imn_plusx ) mn_plusx = q; } for (i=0;imn_pluss ) mn_pluss = q; } mn_minus = mn_minusx * mn_minuss; mn_plus = mn_plusx * mn_pluss; arl_minus = arl + p0[n-1]/(1.-mn_minus); arl_plus = arl + p0[n-1]/(1.-mn_plus); } arl += p0[n-1]; if ( fabs( (arl_plus-arl_minus)/arl_minus )1)(zch[i]) */ for (i=0;i1) mu_before_sigma += ( p0s[n-2] - p0s[n-1] ) * p0x[n-1]; else mu_before_sigma = ( 1. - p0s[n-1] ) * p0x[n-1]; if ( p0s[n-1]1) mu_before_sigma += ( p0x[n-2]-p0x[n-1] ) * p0s[n-1]; else mu_before_sigma = ( 1.-p0x[n-1] ) * p0s[n-1]; if ( p0x[n-1]n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ for (n=q;n<=nmax;n++) { nn = (double) n; /* determine r_n, n=1,2,...,q-1 */ if ( mode==vacl ) { rn = sqrt( 1. - pow(1.-l, 2.*nn) ); } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0;i1 ) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*zr))/l, mu1); for (j=0;j1 ) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i=q */ for (n=q; n<=nmax; n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0; i1 ) fn[(n-1)*N+i] /= p0[q-2]; } } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i=q */ for (n=q; n<=nmax; n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c*norm); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0; i1 ) fn[(n-1)*N+i] /= p0[q-2]; } } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine r_n, n=1,2,...,q-1 */ if ( mode==vacl ) { rn = sqrt( 1. - pow(1.-l, 2.*nn) ); } /* determine f_n, n=q,q+1,... */ if (n==1) { for (i=0;i1) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (cn+rn*zr-(1.-l)*(cn0+rn0*zr))/l, mu1); for (j=0;j1) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2; rho0 = rho; Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return arl; } double xe1_arlm_hom(double l, double c, double zr, double hs, int q, double mu0, double mu1, int N, double *ced) { double *fn, *w, *z, *a, *arl, norm; int i, j, n, NN; NN = N + 1; w = vector(NN); z = vector(NN); fn = matrix(q+1, NN); a = matrix(NN,NN); arl = vector(NN); c *= sqrt( l/(2.-l) ); zr *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); gausslegendre(N, zr, c, z, w); /* ARL vector */ for (i=0; i 1 */ for (n=1; n<=q-1; n++) { if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine f_n, n=q,q+1,... */ if (n==1) { for (i=0;i1) fn[(n-1)*NN+i] /= p0[q-2]; } fn[(n-1)*NN+N] = fn[(n-2)*NN+N] * PHI( (zr-l1*zr)/l2, mu1); for (j=0;j1) fn[(n-1)*NN+N] /= p0[q-2]; } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = fn[(n-1)*NN+N]; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( (p0[n-1]>p0[n-2] || rho>1.) && n>10 ) error("invalid ARL value"); if ( fabs((arl_plus-arl_minus)) < 1e-5 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2; rho0 = rho; Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return arl; } double xe2_arlm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax) { double *Smatrix, *p0, *fn, *w, *z, arl0, rho, dn, rn, cn, rn0, cn0, delta=0., arl_minus=0, arl, arl_plus=0, mn_minus, mn_plus, nn, fSt, aSt, ratio; int i, j, n; fSt = 0.5; aSt = ( -2./log10(1.-fSt) - 1.)/19.; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); if (mode==fir || mode==both) delta = 2.*hs; Smatrix = matrix(N,N); w = vector(N); z = vector(N); fn = matrix(nmax,N); p0 = vector(nmax); gausslegendre(N,-c,c,z,w); rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.; /* in-control, i. e. n<=q-1 */ for (n=1;n<=q-1;n++) { nn = (double) n; /* determine c_n and r_n, n=1,2,...,q-1 */ switch (mode) { case vacl: rn = sqrt( 1. - pow(1.-l, 2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=1,2,...,q-1 */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch (mode) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if (n==1) { for (i=0;i1) fn[(n-1)*N+i] /= p0[q-2]; } } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2; rho0 = rho; Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return arl; } double xe2_arlmc(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax) { double *Smatrix, *p0, *Psi, *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); Psi = 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;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] = Psi[n-1] * rn/l*phi( (cn+rn*z[i]-(1.-l)*hs)/l, mu1); for (j=0;jn), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if (n>q) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2; rho0 = rho; Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return arl; } int xe2_arlm_special(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *pair) { double *Smatrix, *p0, *fn, *w, *z, arl0, rho, dn, rn, cn, rn0, cn0, delta=0., arl_minus=0, arl, arl_plus=0, mn_minus, mn_plus, nn, fSt, aSt, ratio; int i, j, n; fSt = 0.5; aSt = ( -2./log10(1.-fSt) - 1.)/19.; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); if (mode==fir || mode==both) delta = 2.*hs; Smatrix = matrix(N,N); w = vector(N); z = vector(N); fn = matrix(nmax,N); p0 = vector(nmax); gausslegendre(N,-c,c,z,w); rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.; /* in-control, i. e. n<=q-1 */ for (n=1;n<=q-1;n++) { nn = (double) n; /* determine c_n and r_n, n=1,2,...,q-1 */ switch (mode) { case vacl: rn = sqrt( 1. - pow(1.-l, 2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=1,2,...,q-1 */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;i=q */ arl0 = 1.; rho = 0.; for (n=q;n<=nmax;n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch (mode) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if (n==1) { for (i=0;in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;iq) { for (i=0;imn_plus ) mn_plus = ratio; } } if ( n > q ) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if (mn_minus<1.) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if (mn_plus<1.) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = ( arl_plus + arl_minus )/2; pair[0] = 1.; if ( q > 1 ) pair[0] = p0[q-2]; pair[1] = arl; Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return 0; } double xte2_arlm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst) { double *Smatrix, *p0, *fn, *w, *z, arl0, rho, dn, rn, cn, rn0, cn0, delta=0., arl_minus=0, arl, arl_plus=0, mn_minus, mn_plus, nn, fSt, aSt, ratio, norm=1., arg=0., korr=1.; int i, j, n; fSt = 0.5; aSt = ( -2./log10(1.-fSt) - 1.)/19.; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); if (mode==fir || mode==both) delta = 2.*hs; Smatrix = matrix(N,N); w = vector(N); z = vector(N); fn = matrix(nmax,N); p0 = vector(nmax); switch ( subst ) { case IDENTITY: gausslegendre(N, -c, c, z, w); norm = 1.; break; case SIN: gausslegendre(N, -PI/2., PI/2., z, w); norm = 1.; break; case SINH: gausslegendre(N, -1., 1., z, w); norm = sinh(1.); break; case TAN: gausslegendre(N, -PI/4., PI/4., z, w); norm = 1.; break; } c /= norm; rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.; /* in-control, i. e. n<=q-1 */ for (n=1; n<=q-1; n++) { nn = (double) n; /* determine c_n and r_n, n=1,2,...,q-1 */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l, 2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c*norm); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=1,2,...,q-1 */ if ( n==1 ) { for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i=q */ arl0 = 1.; rho = 0.; for (n=q; n<=nmax; n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c*norm); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c*norm); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0; i1 ) fn[(n-1)*N+i] /= p0[q-2]; } } /* determine P(L>n), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0;iq ) { for (i=0; imn_plus ) mn_plus = ratio; } } if ( n>q ) rho = p0[n-1]/p0[n-2]; /* computation of ARL, ARL^-, and ARL^+ */ arl = arl0 + p0[n-1]/(1.-rho); if ( mn_minus<1. ) arl_minus = arl0 + p0[n-1]/(1.-mn_minus); else arl_minus = -1.; if ( mn_plus<1. ) arl_plus = arl0 + p0[n-1]/(1.-mn_plus); else arl_plus = -1.; arl0 += p0[n-1]; if ( fabs((arl_plus-arl_minus)) < 1e-7 ) n = nmax+1; } arl = (arl_plus+arl_minus)/2; rho0 = rho; Free(Smatrix); Free(w); Free(z); Free(fn); Free(p0); return arl; } double xe2_arlm_hom(double l, double c, double hs, int q, double mu0, double mu1, int N, double *ced) { double *fn, *w, *z, *a, *arl, norm; int i, j, n; w = vector(N); z = vector(N); fn = matrix(q+1, N); a = matrix(N,N); arl = vector(N); c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); gausslegendre(N, -c, c, z, w); for (i=0; i 1 */ for (n=1; n<=q-1; n++) { if ( n==1 ) { for (i=0; i 1 */ for (n=1; n<=q-1; n++) { if ( n==1 ) { for (i=0; i 1000 ) qm = 1000;*/ return qm; } /* routines for prerun impact on average ARL, QRL performance */ /* 1. ARL (fixed limits) */ double xe2_iglarl_prerun_MU(double l, double c, double hs, double mu, int pn, int qm, double truncate) { double *w, *z, b, result, dn, sdn; int i, Nlocal; w = vector(qm); z = vector(qm); dn = (double)pn; sdn = sqrt(dn); b = -qPHI(truncate/2.)/sdn; gausslegendre(qm, -b, b, z, w); Nlocal = qm_for_l_and_c(l, c); result = 0.; for (i=0; i1 ) { for (i=0;imn_plus ) mn_plus = ratio; } *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < BOUND ) { *nstop = n; n = nmax + 1; } } } Free(Pn); Free(z); Free(w); Free(Sm); return 0; } double xe2_sfm_simple(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0) { double *Smatrix, *fn, *w, *z, dn, rn, cn, rn0, cn0, delta=0., nn, fSt, aSt; int i, j, n; fSt = 0.5; aSt = ( -2./log10(1.-fSt) - 1.)/19.; c *= sqrt( l/(2.-l) ); hs *= sqrt( l/(2.-l) ); if ( mode==fir || mode==both ) delta = 2.*hs; Smatrix = matrix(N, N); w = vector(N); z = vector(N); fn = matrix(nmax, N); gausslegendre(N, -c, c, z, w); rn = 1.; cn = 0.; rn0 = 1., cn0 = 0.; /* in-control, i. e. n<=q-1 */ for (n=1; n<=q-1; n++) { nn = (double) n; /* determine c_n and r_n, n=1,2,...,q-1 */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=1,2,...,q-1 */ if ( n==1 ) { for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i=q */ for (n=q; n<=nmax; n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; i=q */ for (n=q; n<=nmax; n++) { nn = (double) n; /* determine c_n and r_n, n=q,q+1,... */ switch ( mode ) { case vacl: rn = sqrt( 1. - pow(1.-l,2.*nn) ); break; case fir: dn = delta*pow(1.-l,nn); rn = 1. - dn/(2.*c); cn = dn/2.; break; case both: dn = delta*pow(1.-l,nn); rn = sqrt( 1. - pow(1.-l,2.*nn) ) - dn/(2.*c); cn = dn/2.; break; case steiner: rn = sqrt(1.-pow(1.-l,2.*nn))*(1.-pow(1.-fSt,1.+aSt*(nn-1.))); break; } /* determine f_n, n=q,q+1,... */ if ( n==1 ) { for (i=0; in), n=1,2,...,q-1 */ p0[n-1] = 0.; for (i=0; iq ) { for (i=0;imn_plus ) mn_plus = ratio; } *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < BOUND ) { *nstop = n; n = nmax + 1; } } } Free(Smatrix); Free(w); Free(z); Free(fn); return 0; } /* P(L>n) */ double xe2_sf_prerun_MU_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0) { double *ww, *zz, b, dn, sdn, *SF, rho; int i, m, n, nstop, Nlocal; SF = vector(nmax); ww = vector(qm); zz = vector(qm); dn = (double)pn; sdn = sqrt(dn); b = -qPHI(truncate/2.)/sdn; gausslegendre(qm, -b, b, zz, ww); for (i=0; i 0 ) { for (n=0; n 0 ) { for (n=0; n 1 ) for (n=q-1; n 1 ) for (n=q-1; n 0 ) { for (n=0; n 0 ) { for (n=0; n 1 ) for (n=q-1; n 1 ) for (n=q-1; n 0 ) { for (n=0; n 0 ) { for (n=0; n 1 ) for (n=q-1; n 1 ) for (n=q-1; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; j = xe2_sf_deluxe(l, c, hs, zz[qnspecial-1]+mu, Nlocal, nmax, BOUND, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 0 ) n--; if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.; } else { for (n=nn; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; j = xe2_sfm_deluxe(l, c, hs, q, zz[qnspecial-1]+mu0, zz[qnspecial-1]+mu1, mode, Nlocal, nmax, BOUND, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 1 ) sf_level_adj *= p0[q-2]; if ( p0[nn-1] <= sf_level_adj ) { n = nn-1; while ( p0[n] <= sf_level_adj && n > 0 ) n--; if ( p0[n] > sf_level_adj ) Lp = (double)( n + 2 - q + 1 ); else Lp = 1.; } else { for (n=nn; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; Nlocal = qm_for_l_and_c(l, zz[qnspecial-1]*c); j = xe2_sf_deluxe(l, zz[qnspecial-1]*c, hs, mu, Nlocal, nmax, BOUND, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sf_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 0 ) n--; if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.; } else { for (n=nn; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; Nlocal = qm_for_l_and_c(l, zz[qnspecial-1]*c); j = xe2_sfm_deluxe(l, zz[qnspecial-1]*c, hs, q, mu0, mu1, mode, Nlocal, nmax, BOUND, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function xe2_sfm_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 1 ) sf_level_adj *= p0[q-2]; if ( p0[nn-1] <= sf_level_adj ) { n = nn-1; while ( p0[n] <= sf_level_adj && n > 0 ) n--; if ( p0[n] > sf_level_adj ) Lp = (double)( n + 2 - q + 1 ); else Lp = 1.; } else { for (n=nn; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n nstop ) { for (n=nstop; n 0 ) n--; if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.; } else { for (n=nn; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n nstop ) { for (n=nstop; n 1 ) sf_level_adj *= p0[q-2]; if ( p0[nn-1] <= sf_level_adj ) { n = nn-1; while ( p0[n] <= sf_level_adj && n > 0 ) n--; if ( p0[n] > sf_level_adj ) Lp = (double)( n + 2 - q + 1 ); else Lp = 1.; } else { for (n=nn; nz2) a[i1*N3+j1*NN+i2*N+j2] = 0.; else a[i1*N3+j1*NN+i2*N+j2] = -PHI(z2,mu1) + PHI(z1,mu1); if (i1==i2 && j1==j2) a[i1*N3+j1*NN+i2*N+j2]++; } for (j1=0;j1z2) a[i2*N3+j2*NN+i1*N+j1] = 0.; else a[i2*N3+j2*NN+i1*N+j1] = PHI(z2,mu0) - PHI(z1,mu0); } pmethod(NN,a,&status,&rho,psi,&noofit); ad = 0.; norm = 0.; for (i1=0;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); } /* density sequence for q > 1 */ for (n=1; n<=q-1; n++) { if (n==1) { for (i1=0; i1 5 ) result = cos( (double)(n)*acos(z) ); } else { if ( z<0. && (n % 2 == 1) ) result = -1.; else result = 1.; } return result; } /* -------------- indefinite integrals of Chebyshev polynomials on [-1,1] ----------------- */ double iTn(double z, int n) { double result=1.; switch (n) { case 0: result = z; break; case 1: result = z*z/2.; break; case 2: result = 2.*z*z*z/3. - z; break; } if ( n > 2 ) result = ( Tn(z,n+1)/(n+1.) - Tn(z,n-1)/(n-1.) )/2.; return result; } /* -------------- derivatives of Chebyshev polynomials on [-1,1] ----------------- */ double dTn(double z, int n) { double result=1., dn; dn = (double)n; if ( fabs(z)<1-1e-12 ) { switch (n) { case 0: result = 0.; break; case 1: result = 1.; break; case 2: result = 4.*z; break; case 3: result = 12.*z*z-3.; break; case 4: result = 32.*z*z*z-16.*z; break; case 5: result = 80.*pow(z,4.)-60.*z*z+5.; break; } if ( n > 5 ) result = dn * ( Tn(z,n-1) - z*Tn(z,n) ) / (1.-z*z); } else { if ( z<0. && (n % 2 == 0) ) result = -dn*dn; else result = dn*dn; } return result; } double seU_iglarl(double l, double cu, double hs, double sigma, int df, int N, int qm) { double *a, *g, *w, *z, arl, Hij, xi, xl, za, xu, dN, ddf, s2, v; int i, j, k; s2 = sigma*sigma; ddf = (double)df; dN = (double)N; a = matrix(N,N); g = vector(N); w = vector(qm); z = vector(qm); for (i=0;i2 ) Hij += w[k] * Tn( (2.*(z[k]*z[k]+za)-cu)/cu, j) * ddf/s2/l * chi(ddf*z[k]*z[k]/s2/l,df) * 2*z[k]; } if (df==1) Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.); if (df==2) Hij /= s2*l; a[i*N+j] = Tn( (2.*xi-cu)/cu ,j) - Hij; } } for (j=0;j1)(zch[i]) */ for (i=0; i1)(zch[i]) */ for (i=0; i 1 ) { for (i=0; imn_plus ) mn_plus = q; } *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < FINALeps ) { *nstop = n; n = nmax + 1; } } /* n > 1 */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); return 0; } int choose_N_for_seU(double lambda) { int N=20; N = 25; if ( 0.1 <= lambda && lambda < 0.2 ) N = 35; if ( 0.05 <= lambda && lambda < 0.1 ) N = 50; if ( 0.02 <= lambda && lambda < 0.05) N = 70; if ( 0.01 <= lambda && lambda < 0.02) N = 100; if ( lambda < 0.01 ) N = 150; return N; } int choose_N_for_se2(double lambda, double cl, double cu) { int N=20, M=1; M = ceil( ( log(cl) - log(cu) )/log( 1. - lambda ) ); N = 5; if ( 0.1 <= lambda && lambda < 0.2 ) N = 10; if ( 0.05 <= lambda && lambda < 0.1 ) N = 20; if ( 0.02 <= lambda && lambda < 0.05) N = 40; if ( 0.01 <= lambda && lambda < 0.02) N = 60; if ( lambda < 0.01 ) N = 90; N *= M; if ( N < 30 ) N = 30; if ( N > 200 ) N = 200; return N; } double seU_sf_prerun_SIGMA_deluxe(double l, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0) { double *ww, *zz, b1, b2, ddf2, *SF, rho, s2; int i, m, n, nstop, Nlocal; Nlocal = choose_N_for_seU(l); SF = vector(nmax); ww = vector(qm2); zz = vector(qm2); ddf2 = (double)(df2); b1 = qCHI( truncate/2., df2)/ddf2; b2 = qCHI(1. - truncate/2., df2)/ddf2; gausslegendre(qm2, b1, b2, zz, ww); for (i=0; i 0 ) { for (n=0; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; s2 = zz[qnspecial-1]; j = seU_sf_deluxe(l, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 0 ) n--; if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.; } else { for (n=nn; n1)(zch[i]) */ for (i=0; i 1 ) { for (i=0; imn_plus ) mn_plus = q; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); /*if ( fabs( (q_plus-q_minus)/q_minus ) 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(p0); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); return Wq; } double seU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3, norm; norm = sqrt(df); s2 = hs - .15; L2 = 0.; do { s1 = s2; L1 = L2; s2 += .2/norm; L2 = seU_iglarl(l,s2,hs,sigma,df,N,qm); } while ( L2 < L0 ); do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = seU_iglarl(l,s3,hs,sigma,df,N,qm); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-9 ); return s3; } double stdeU_crit(double l, double L0, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3, norm; norm = sqrt(df); s2 = hs - .15; L2 = 0.; do { s1 = s2; L1 = L2; s2 += .2/norm; L2 = stdeU_iglarl(l,s2,hs,sigma,df,N,qm); } while ( L2 < L0 ); do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = stdeU_iglarl(l,s3,hs,sigma,df,N,qm); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-9 ); return s3; } double seU_crit_prerun_SIGMA(double l, double L0, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate) { double s1, s2, s3, ds, L1=0., L2=0., L3=0.; s2 = hs; do { L1 = L2; s2 += .2; L2 = seU_iglarl_prerun_SIGMA(l, s2, hs, sigma, df1, df2, N, qm1, qm2, truncate); } while ( L2 < L0 ); s1 = s2 - .2; do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = seU_iglarl_prerun_SIGMA(l, s3, hs, sigma, df1, df2, N, qm1, qm2, truncate); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-9 ); return s3; } double seU_q_crit(double l, int L0, double alpha, double hs, double sigma, int df, int N, int qm, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = hs; p2 = 1.; do { p1 = p2; s2 += .2; result = seU_sf(l, s2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in seU_q_crit [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha ); s1 = s2 - .2; do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); result = seU_sf(l, s3, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in seU_q_crit [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double seU_q_crit_prerun_SIGMA(double l, int L0, double alpha, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = seU_q_crit(l, L0, alpha, hs, sigma, df1, N, qm1, c_error, a_error); if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seU_sf_prerun_SIGMA(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seU_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; if ( p2 > alpha ) { do { p1 = p2; s2 += .2; if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seU_sf_prerun_SIGMA(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seU_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha ); s1 = s2 - .2; } else { do { p1 = p2; s2 -= .2; if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seU_sf_prerun_SIGMA(l, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seU_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 <= alpha && s2 > hs ); s1 = s2 + .2; } do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seU_sf_prerun_SIGMA(l, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seU_q_crit_prerun_SIGMA [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double se2_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm) { double *a, *g, *w, *z, *t, h, arl, Hij, xl, za, dN, ddf, s2, t0, t1, x0, x1; int i, j, k, qi, qj, M, Ntilde, NN, ii, it, jj; M = ceil( (log(cl) - log(cu))/log(1.-l) ); Ntilde = ceil( (double)N/(double)M ); NN = M*Ntilde; s2 = sigma*sigma; ddf = (double)df; dN = (double)Ntilde - 1.; a = matrix(NN, NN); g = vector(NN); t = vector(NN); w = vector(qm); z = vector(qm); for(i=0;icu) t1 = cu; for (j=1;j0) { qi = i-1; t0 = cl/pow(1.-l,(double)qi); t1 = t0/(1.-l); if (t1>cu) t1 = cu; if (t01e-10) x0 = sqrt(x0-za); else x0 = 0.; if (t1-za>1e-10) x1 = sqrt(t1-za); else x1 = 0.; } for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; if (j==1) a[ii*NN+jj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1); else { if (fabs(t1-x0)>1e-8) { gausslegendre(qm,x0,x1,z,w); Hij = 0.; for (k=0;k2 ) Hij += w[k] * Tn( (2.*(z[k]*z[k]+za)-t0-t1)/(t1-t0) ,qj-1) * ddf/s2/l * chi(ddf*z[k]*z[k]/s2/l, df) * 2*z[k]; } if (df==1) Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.); if (df==2) Hij /= s2*l; a[ii*NN+jj] = -Hij; } else a[ii*NN+jj] = 0.; } } } for (qi=i;qicu) 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;k2 ) Hij += w[k] * Tn( (2.*(z[k]*z[k]+za)-t0-t1)/(t1-t0) ,qj-1) * ddf/s2/l * chi(ddf*z[k]*z[k]/s2/l, df) * 2*z[k]; } if (df==1) Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.); if (df==2) Hij /= s2*l; if (qi==i) a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1) - Hij; else a[ii*NN+jj] = -Hij; } } } } } for (j=0;jcu) t1 = cu; if (t0<=hs && hscu ) t1 = cu; for (j=1; j0 ) { qi = i-1; t0 = cl/pow(1.-l,(double)qi); t1 = t0/(1.-l); if ( t1>cu ) t1 = cu; if ( t01e-8 ) { gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; kcu ) t1 = cu; if ( t00 && j==1 && qi==i ) { for (qj=1; qj<=Ntilde; qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1); } } if ( i>0 && j==1 && qi>i ) { for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = 0.; } } if ( i==0 || j>1 ) { for ( qj=1; qj<=Ntilde; qj++) { jj = qi*Ntilde + qj-1; gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; kcu ) t1 = cu; if ( t0<=hs && hs1)(zch[i,j]) */ for (i=0; i1)(zch[i,j]) */ for (i=0; i 1) { for (i=0; imn_plus ) mn_plus = q; } *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < FINALeps ) { *nstop = n; n = nmax + 1; } } /* n > 1 */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); return 0; } double se2_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0) { double *ww, *zz, b1, b2, ddf2, *SF, rho, s2; int i, m, n, nstop, Nlocal; Nlocal = choose_N_for_se2(l, cl, cu); SF = vector(nmax); ww = vector(qm2); zz = vector(qm2); ddf2 = (double)(df2); b1 = qCHI( truncate/2., df2)/ddf2; b2 = qCHI(1. - truncate/2., df2)/ddf2; gausslegendre(qm2, b1, b2, zz, ww); for (i=0; i 0 ) { for (n=0; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; s2 = zz[qnspecial-1]; j = se2_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 0 ) n--; if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.; } else { for (n=nn; n1)(zch[i,j]) */ for (i=0; i 1) { for (i=0; imn_plus ) mn_plus = q; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); /*if ( fabs( (q_plus-q_minus)/q_minus ) 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(p0); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); return Wq; } double se2lu_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3; s2 = hs; do { s2 += .2; L2 = se2_iglarl(l,cl,s2,hs,sigma,df,N,qm); } while ( L2 < L0 ); s1 = s2 - .2; L1 = se2_iglarl(l,cl,s1,hs,sigma,df,N,qm); do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = se2_iglarl(l,cl,s3,hs,sigma,df,N,qm); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-9 ); return s3; } double stde2lu_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3; s2 = hs; L2 = 0.; do { s1 = s2; L1 = L2; s2 += .2; L2 = stde2_iglarl(l, cl, s2, hs, sigma, df, N, qm); } while ( L2 < L0 ); do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = stde2_iglarl(l, cl, s3, hs, sigma, df, N, qm); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-9 ); return s3; } double se2lu_crit_prerun_SIGMA(double l, double L0, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate) { double s1, s2, s3, ds, L1=0., L2=0., L3=0.; s2 = hs; do { L1 = L2; s2 += .2; L2 = se2_iglarl_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, N, qm1, qm2, truncate); } while ( L2 < L0 ); s1 = s2 - .2; do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = se2_iglarl_prerun_SIGMA(l, cl, s3, hs, sigma, df1, df2, N, qm1, qm2, truncate); ds = s3 - s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-9 ); return s3; } double se2lu_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = hs; p2 = 1.; do { p1 = p2; s2 += .2; result = se2_sf(l, cl, s2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2lu_q_crit [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha ); s1 = s2 - .2; do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); result = se2_sf(l, cl, s3, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2lu_q_crit [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double se2lu_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = se2lu_q_crit(l, L0, alpha, cl, hs, sigma, df1, N, qm1, c_error, a_error); if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2lu_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; if ( p2 > alpha ) { do { p1 = p2; s2 += .2; if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2lu_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha ); s1 = s2 - .2; } else { do { p1 = p2; s2 -= .2; if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2lu_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 <= alpha && s2 > hs ); s1 = s2 + .2; } do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, cl, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, cl, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2lu_q_crit_prerun_SIGMA [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double se2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3, rescale=1.1; /*printf("\nse2fu_crit\n");*/ rescale = 1. + 1./(double)df; s2 = 2. - cu; if ( s2 < 0.1 ) s2 = 0.1; L2 = se2_iglarl(l,s2,cu,hs,sigma,df,N,qm); /*printf("(*) 0 :: cu = %.6f,\tcl = %.6f,\tL = %.6f\n\n", cu, s2, L2);*/ if ( L2 < L0 ) { do { s1 = s2; s2 /= rescale; L2 = se2_iglarl(l,s2,cu,hs,sigma,df,N,qm); /*printf("(*) 1 :: cu = %.6f,\tcl = %.6f,\tL = %.6f\n", cu, s2, L2);*/ } while ( L2 < L0 ); } else { do { s1 = s2; s2 *= rescale; L2 = se2_iglarl(l,s2,cu,hs,sigma,df,N,qm); /*printf("(*) 1 :: cu = %.6f,\tcl = %.6f,\tL = %.6f\n", cu, s2, L2);*/ } while ( L2 > L0 ); } /*printf("\n");*/ 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); /*printf("(*) 3 :: cu = %.6f,\tcl = %.6f,\tL = %.6f\n", cu, s3, L3);*/ ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-9 ); /*printf("\n\n");*/ return s3; } double stde2fu_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3, norm; norm = sqrt(df); s2 = 2. - cu; if ( s2 < 0.1 ) s2 = 0.1; L2 = stde2_iglarl(l, s2, cu, hs, sigma, df, N, qm); if ( L2 < L0 ) { do { s1 = s2; L1 = L2; s2 -= .2/norm; L2 = stde2_iglarl(l, s2, cu, hs, sigma, df, N, qm); } while ( L2 < L0 ); } else { do { s1 = s2; L1 = L2; s2 += .2/norm; L2 = stde2_iglarl(l, s2, cu, hs, sigma, df, N, qm); } while ( L2 > L0 ); } do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = stde2_iglarl(l, s3, cu, hs, sigma, df, N,qm); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-9 ); return s3; } double se2fu_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate) { double s1, s2, s3, ds, L1=0., L2=0., L3=0.; s2 = cu/2.; L2 = se2_iglarl_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate); if ( L2 < L0 ) { do { L1 = L2; s2 -= .1; L2 = se2_iglarl_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate); } while ( L2 < L0 && s2 > 0.); s1 = s2 + .1; } else { do { L1 = L2; s2 += .1; L2 = se2_iglarl_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate); } while ( L2 > L0 && s2 < hs ); s1 = s2 - .1; } do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = se2_iglarl_prerun_SIGMA(l, s3, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-9 ); return s3; } double se2fu_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); /*s2 = cu/2.; */ s2 = hs/2.; result = se2_sf(l, s2, cu, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit [package spc]"); p2 = 1. - SF[L0-1]; if ( p2 < alpha ) { do { p1 = p2; s2 *= 1.2; result = se2_sf(l, s2, cu, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 < alpha ); s1 = s2 - .1; } else { do { p1 = p2; s2 /= 1.2; result = se2_sf(l, s2, cu, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 >= alpha ); s1 = s2 + .1; } do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); result = se2_sf(l, s3, cu, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double se2fu_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double s0, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1, schritt=0, maxschritt=30; SF = vector(L0); if ( s0 <= 0.0 ) { s2 = se2fu_q_crit(l, L0, alpha, cu, hs, sigma, df1, N, qm1, c_error, a_error); } else { s2 = s0; } /*printf("\nfixed upper limit\n\n(||)\t cl = %.6f\n\n", s2);*/ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; if ( p2 < alpha ) { do { p1 = p2; s1 = s2; s2 *= 1.05; /*printf("<<\t cl = %.6f\n", s2);*/ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 < alpha && s2 < hs ); } else { do { p1 = p2; s1 = s2; s2 /= 1.05; /*printf(">>\t cl = %.6f\n", s2);*/ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 >= alpha && s2 > 0. ); } /*printf("\n");*/ schritt = 0; do { schritt++; s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); /*printf("## \t cl = %.6f\n", s3);*/ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, s3, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, s3, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2fu_q_crit_prerun_SIGMA [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error && schritt= maxschritt ) warning("secant rule in se2fu_q_crit_prerun_SIGMA did not converge"); /*printf("\n\nschritt = %d\n\n", schritt);*/ Free(SF); return s3; } int se2_crit_prerun_SIGMA(double l, double L0, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate) { double s1, s2, s3, ds, sl1, sl2, sl3, csl, Lm, Lp; csl = hs/2.; s1 = se2lu_crit_prerun_SIGMA(l, L0, csl, hs, sigma, df1, df2, N, qm1, qm2, truncate); Lm = se2_iglarl_prerun_SIGMA(l, csl, s1, hs, sigma-lmEPS, df1, df2, N, qm1, qm2, truncate); Lp = se2_iglarl_prerun_SIGMA(l, csl, s1, hs, sigma+lmEPS, df1, df2, N, qm1, qm2, truncate); sl1 = (Lp-Lm)/(2.*lmEPS); s2 = s1 + .05; csl = se2fu_crit_prerun_SIGMA(l, L0, s2, hs, sigma, df1, df2, N, qm1, qm2, truncate); Lm = se2_iglarl_prerun_SIGMA(l, csl, s2, hs, sigma-lmEPS, df1, df2, N, qm1, qm2, truncate); Lp = se2_iglarl_prerun_SIGMA(l, csl, s2, hs, sigma+lmEPS, df1, df2, N, qm1, qm2, truncate); sl2 = (Lp-Lm)/(2.*lmEPS); do { s3 = s1 - sl1/(sl2-sl1) * (s2-s1); csl = se2fu_crit_prerun_SIGMA(l, L0, s3, hs, sigma, df1, df2, N, qm1, qm2, truncate); Lm = se2_iglarl_prerun_SIGMA(l, csl, s3, hs, sigma-lmEPS, df1, df2, N, qm1, qm2, truncate); Lp = se2_iglarl_prerun_SIGMA(l, csl, s3, hs, sigma+lmEPS, df1, df2, N, qm1, qm2, truncate); sl3 = (Lp-Lm)/(2.*lmEPS); ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; } while ( fabs(sl3)>1e-6 && fabs(ds)>1e-9 ); *cl = csl; *cu = s3; return 0; } int se2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm) { double s1, s1b, s2, s3, ds, sl1, sl2, sl3, csl, Lm, Lp, step, cE; /*printf("\n\nse2_crit_unbiased\n\n");*/ /* new */ cE = xe_crit(ewma2, l, L0, 0., 0., 0., fix, 100, 0.); s1b = seU_crit(l,L0,hs,sigma,df,N,qm); step = .1; do { s1 = 1. + (cE+step) * sqrt( 2.*l/(2.-l)/(double)df ); step += .1; } while ( s1 < s1b ); s1 = 1. + (cE+step) * sqrt( 2.*l/(2.-l)/(double)df ); csl = se2fu_crit(l,L0,s1,hs,sigma,df,N,qm); Lm = se2_iglarl(l,csl,s1,hs,sigma-lmEPS,df,N,qm); Lp = se2_iglarl(l,csl,s1,hs,sigma+lmEPS,df,N,qm); sl1 = (Lp-Lm)/(2.*lmEPS); /*printf("0 :: cl = %.4f,\tcu = %.6f (%.6f),\tsl = %.6f\n\n", csl, s1, s1b, sl1);*/ /*s1 = seU_crit(l,L0,hs,sigma,df,N,qm); csl = 0.; Lm = seU_iglarl(l,s1,hs,sigma-lmEPS,df,N,qm); Lp = seU_iglarl(l,s1,hs,sigma+lmEPS,df,N,qm); sl1 = (Lp-Lm)/(2.*lmEPS); printf("0 :: cl = %.4f,\tcu = %.6f,\tsl = %.6f\n\n", csl, s1, sl1);*/ s2 = s1; sl2 = sl1; /*step = 1./sqrt( (double)df );*/ step = (s2 - s1b)/2.; if ( sl2 < 0 ) { do { s1 = s2; sl1 = sl2; s2 = s1 + step; csl = se2fu_crit(l,L0,s2,hs,sigma,df,N,qm); Lm = se2_iglarl(l,csl,s2,hs,sigma-lmEPS,df,N,qm); Lp = se2_iglarl(l,csl,s2,hs,sigma+lmEPS,df,N,qm); sl2 = (Lp-Lm)/(2.*lmEPS); /*printf("1a :: cl = %.4f,\tcu = %.6f,\tsl = %.6f\n", csl, s2, sl2);*/ } while ( sl2 < 0. ); step /= 5.; do { s1 = s2; sl1 = sl2; s2 = s1 - step; csl = se2fu_crit(l,L0,s2,hs,sigma,df,N,qm); Lm = se2_iglarl(l,csl,s2,hs,sigma-lmEPS,df,N,qm); Lp = se2_iglarl(l,csl,s2,hs,sigma+lmEPS,df,N,qm); sl2 = (Lp-Lm)/(2.*lmEPS); /*printf("1ab :: cl = %.4f,\tcu = %.6f,\tsl = %.6f\n", csl, s2, sl2);*/ } while ( sl2 > 0. ); } else { /*step /= 10.;*/ step = (s2 - s1b)/10.; do { s1 = s2; sl1 = sl2; s2 = s1 - step; if ( s2 < s1b ) { s2 = s1b; csl = 0.; } else { 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); /*printf("1b :: cl = %.4f,\tcu = %.6f,\tsl = %.6f\n", csl, s2, sl2);*/ } while ( sl2 > 0. ); step /= 5.; do { s1 = s2; sl1 = sl2; s2 = s1 + step; csl = se2fu_crit(l,L0,s2,hs,sigma,df,N,qm); Lm = se2_iglarl(l,csl,s2,hs,sigma-lmEPS,df,N,qm); Lp = se2_iglarl(l,csl,s2,hs,sigma+lmEPS,df,N,qm); sl2 = (Lp-Lm)/(2.*lmEPS); /*printf("1ba :: cl = %.4f,\tcu = %.6f,\tsl = %.6f\n", csl, s2, sl2);*/ } while ( sl2 < 0. ); } /*printf("\n");*/ 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); /*printf("2 :: cl = %.4f,\tcu = %.6f,\tsl = %.6f\n", csl, s3, sl3);*/ ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; } while ( fabs(sl3)>1e-6 && fabs(ds)>1e-12 ); *cl = csl; *cu = s3; /*printf("\n\n");*/ return 0; } int stde2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, sl1, sl2, sl3, csl, Lm, Lp, step; step = .1/sqrt(df); s1 = stdeU_crit(l, L0, hs, sigma, df, N, qm); csl = 0.; Lm = stdeU_iglarl(l, s1, hs, sigma-lmEPS, df, N, qm); Lp = stdeU_iglarl(l, s1, hs, sigma+lmEPS, df, N, qm); sl1 = (Lp-Lm)/(2.*lmEPS); s2 = s1; sl2 = sl1; do { s1 = s2; sl1 = sl2; s2 = s1 + step; csl = stde2fu_crit(l, L0, s2, hs, sigma, df, N, qm); Lm = stde2_iglarl(l, csl, s2, hs, sigma-lmEPS, df, N, qm); Lp = stde2_iglarl(l, csl, s2, hs, sigma+lmEPS, df, N, qm); sl2 = (Lp-Lm)/(2.*lmEPS); } while ( sl2 < 0. ); do { s3 = s1 - sl1/(sl2-sl1) * (s2-s1); csl = stde2fu_crit(l, L0, s3, hs, sigma, df, N, qm); Lm = stde2_iglarl(l, csl, s3, hs, sigma-lmEPS, df, N, qm); Lp = stde2_iglarl(l, csl, s3, hs, sigma+lmEPS, df, N, qm); sl3 = (Lp-Lm)/(2.*lmEPS); ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; } while ( fabs(sl3)>1e-7 && fabs(ds)>1e-9 ); *cl = csl; *cu = s3; return 0; } int se2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm) { double u1, u2, du, l1, l2, dl, lARL1, lARL2, uARL1, uARL2, ARL22, ARL12, ARL21, f11, f22, f21, f12, d11, d22, d21, d12, nenner; l1 = seLR_crit(l, 2.*L0, ur, hs, sigma, df, N, qm); l2 = l1 * 0.9;; u1 = seU_crit(l, 2.*L0, hs, sigma, df, N, qm); u2 = u1 * 1.1; /*ARL22 = se2_iglarl(l, l1, u1, hs, sigma, df, N, qm);*/ lARL2 = seLR_iglarl(l, l2, ur, hs, sigma, df, N, qm); uARL2 = seU_iglarl(l, u2, hs, sigma, df, N, qm); ARL22 = se2_iglarl(l, l2, u2, hs, sigma, df, N, qm); /*printf("(+)\tl1 = %.6f,\tu1 = %.6f\n", l1, u1); printf("(+)\tl2 = %.6f,\tu2 = %.6f,\tllARL2 = %.2f,\tuARL2 = %.2f,\tARL22 = %.2f\n\n", l2, u2, lARL2, uARL2, ARL22);*/ do { lARL1 = seLR_iglarl(l, l1, ur, hs, sigma, df, N, qm); uARL1 = seU_iglarl(l, u1, hs, sigma, df, N, qm); ARL12 = se2_iglarl(l, l1, u2, hs, sigma, df, N, qm); ARL21 = se2_iglarl(l, l2, u1, hs, sigma, df, N, qm); /*printf("(*)\tlARL1 = %.2f,\tuARL1 = %.2f,\tARL12 = %.2f,\tARL21 = %.2f\n", lARL1, uARL1, ARL12, ARL21);*/ /* difference quotient */ f11 = (ARL22 - ARL12)/(l2-l1); f12 = (ARL22 - ARL21)/(u2-u1); f21 = (lARL2 - lARL1)/(l2-l1); f22 = (uARL1 - uARL2)/(u2-u1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dl = d11*(ARL22-L0) + d12*(lARL2-uARL2); du = d21*(ARL22-L0) + d22*(lARL2-uARL2); l1 = l2; u1 = u2; l2 -= dl; u2 -= du; lARL2 = seLR_iglarl(l, l2, ur, hs, sigma, df, N, qm); uARL2 = seU_iglarl(l, u2, hs, sigma, df, N, qm); ARL22 = se2_iglarl(l, l2, u2, hs, sigma, df, N, qm); /*printf("(*)\tl2 = %.6f,\tu2 = %.6f,\tlARL2 = %.2f,\tuARL2 = %.2f,\tARL22 = %.2f\n\n", l2, u2, lARL2, uARL2, ARL22);*/ } while ( (fabs(L0-ARL22)>1e-6 || fabs(lARL2-uARL2)>1e-6) && (fabs(l2-l1)>1e-9 || fabs(u2-u1)>1e-9) ); *cl = l2; *cu = u2; return 0; } int stde2_crit_eqtails(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm) { double u1, u2, du, l1, l2, dl, lARL1, lARL2, uARL1, uARL2, ARL22, ARL12, ARL21, f11, f22, f21, f12, d11, d22, d21, d12, nenner; l1 = stdeLR_crit(l, 2.*L0, ur, hs, sigma, df, N, qm); l2 = l1 - .05; u1 = stdeU_crit(l, 2.*L0, hs, sigma, df, N, qm); u2 = u1 + .05; ARL22 = stde2_iglarl(l, l1, u1, hs, sigma, df, N, qm); lARL2 = stdeLR_iglarl(l, l2, ur, hs, sigma, df, N, qm); uARL2 = stdeU_iglarl(l, u2, hs, sigma, df, N, qm); ARL22 = stde2_iglarl(l, l2, u2, hs, sigma, df, N, qm); do { lARL1 = stdeLR_iglarl(l, l1, ur, hs, sigma, df, N, qm); uARL1 = stdeU_iglarl(l, u1, hs, sigma, df, N, qm); ARL12 = stde2_iglarl(l, l1, u2, hs, sigma, df, N, qm); ARL21 = stde2_iglarl(l, l2, u1, hs, sigma, df, N, qm); /* difference quotient */ f11 = (ARL22 - ARL12)/(l2-l1); f12 = (ARL22 - ARL21)/(u2-u1); f21 = (lARL2 - lARL1)/(l2-l1); f22 = (uARL1 - uARL2)/(u2-u1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dl = d11*(ARL22-L0) + d12*(lARL2-uARL2); du = d21*(ARL22-L0) + d22*(lARL2-uARL2); l1 = l2; u1 = u2; l2 -= dl; u2 -= du; lARL2 = stdeLR_iglarl(l, l2, ur, hs, sigma, df, N, qm); uARL2 = stdeU_iglarl(l, u2, hs, sigma, df, N, qm); ARL22 = stde2_iglarl(l, l2, u2, hs, sigma, df, N, qm); } while ( (fabs(L0-ARL22)>1e-6 || fabs(lARL2-uARL2)>1e-6) && (fabs(l2-l1)>1e-9 || fabs(u2-u1)>1e-9) ); *cl = l2; *cu = u2; return 0; } double se2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm) { double cu1, cu2, cu3, cl1, cl2, cl3, L1, L2, L3, du, step; cu2 = seU_crit(l, L0, hs, sigma, df, N, qm); if ( cu2 < 2. ) { step = (2.-cu2)/10.; cu2 += step; cl2 = 2. - cu2; L2 = se2_iglarl(l, cl2, cu2, hs, sigma, df, N, qm); cu1 = cu2 + step; cl1 = 2. - cu1; L1 = se2_iglarl(l, cl1, cu1, hs, sigma, df, N, qm); do { cu3 = cu1 + (L0-L1)/(L2-L1) * (cu2-cu1); cl3 = 2. - cu3; L3 = se2_iglarl(l, cl3, cu3, hs, sigma, df, N, qm); du = cu3-cu2; cu1 = cu2; L1 = L2; cu2 = cu3; L2 = L3; if ( L3 < 1. ) error("invalid ARL value"); } while ( (fabs(L0-L3)>1e-6) && (fabs(du)>1e-9) ); } else { error("symmetric design not possible"); cu3 = -1.; } return cu3; } double stde2_crit_sym(double l, double L0, double hs, double sigma, int df, int N, int qm) { double cu1, cu2, cu3, cl1, cl2, cl3, L1, L2, L3, du, step, mitte; mitte = c_four((double)df); cu2 = stdeU_crit(l, L0, hs, sigma, df, N, qm); if ( cu2 < 2. ) { step = (2.-cu2)/10.; cu2 += step; cl2 = 2.*mitte - cu2; L2 = stde2_iglarl(l, cl2, cu2, hs, sigma, df, N, qm); cu1 = cu2 + step; cl1 = 2.*mitte - cu1; L1 = stde2_iglarl(l, cl1, cu1, hs, sigma, df, N, qm); do { cu3 = cu1 + (L0-L1)/(L2-L1) * (cu2-cu1); cl3 = 2.*mitte - cu3; L3 = stde2_iglarl(l, cl3, cu3, hs, sigma, df, N, qm); du = cu3-cu2; cu1 = cu2; L1 = L2; cu2 = cu3; L2 = L3; if ( L3 < 1. ) error("invalid ARL value"); } while ( (fabs(L0-L3)>1e-7) && (fabs(du)>1e-9) ); } else { error("symmetric design not possible"); cu3 = -1.; } return cu3; } int se2_q_crit(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error) { double s1, s2, s3, ds, sl1, sl2, sl3, csl, Pm, Pp, *SF; int result=1; SF = vector(L0); s1 = seU_q_crit(l, L0, alpha, hs, sigma, df, N, qm, c_error, a_error); csl = 0.; result = seU_sf(l, s1, hs, sigma-lmEPS, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit [package spc]"); Pm = 1. - SF[L0-1]; result = seU_sf(l, s1, hs, sigma+lmEPS, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit [package spc]"); Pp = 1. - SF[L0-1]; sl1 = ( Pp - Pm )/(2.*lmEPS); s2 = s1 + .05; csl = se2fu_q_crit(l, L0, alpha, s2, hs, sigma, df, N, qm, c_error, a_error); result = se2_sf(l, csl, s2, hs, sigma-lmEPS, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit [package spc]"); Pm = 1. - SF[L0-1]; result = se2_sf(l, csl, s2, hs, sigma+lmEPS, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit [package spc]"); Pp = 1. - SF[L0-1]; sl2 = ( Pp - Pm )/(2.*lmEPS); do { s3 = s1 - sl1/(sl2-sl1) * (s2-s1); csl = se2fu_q_crit(l, L0, alpha, s3, hs, sigma, df, N, qm, c_error, a_error); result = se2_sf(l, csl, s3, hs, sigma-lmEPS, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit [package spc]"); Pm = 1. - SF[L0-1]; result = se2_sf(l, csl, s3, hs, sigma+lmEPS, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit [package spc]"); Pp = 1. - SF[L0-1]; sl3 = ( Pp - Pm )/(2.*lmEPS); ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; } while ( fabs(sl3)>a_error && fabs(ds)>c_error ); *cl = csl; *cu = s3; Free(SF); return 0; } int se2_q_crit_class(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df, double ur, int N, int qm, double c_error, double a_error) { double u1, u2, du, l1, l2, dl, lA1, lA2, uA1, uA2, A22, A12, A21, f11, f22, f21, f12, d11, d22, d21, d12, nenner, *SF; int result=1; SF = vector(L0); l1 = seLR_q_crit(l, L0, alpha/2., ur, hs, sigma, df, N, qm, c_error, a_error); l2 = l1 - .05; u1 = seU_q_crit(l, L0, alpha/2., hs, sigma, df, N, qm, c_error, a_error); u2 = u1 + .05; result = seLR_sf(l, l2, ur, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); lA2 = 1. - SF[L0-1]; result = seU_sf(l, u2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); uA2 = 1. - SF[L0-1]; result = se2_sf(l, l2, u2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); A22 = 1. - SF[L0-1]; do { result = seLR_sf(l, l1, ur, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); lA1 = 1. - SF[L0-1]; result = seU_sf(l, u1, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); uA1 = 1. - SF[L0-1]; result = se2_sf(l, l1, u2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); A12 = 1. - SF[L0-1]; result = se2_sf(l, l2, u1, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); A21 = 1. - SF[L0-1]; /* difference quotient */ f11 = (A22 - A12)/(l2-l1); f12 = (A22 - A21)/(u2-u1); f21 = (lA2 - lA1)/(l2-l1); f22 = (uA1 - uA2)/(u2-u1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dl = d11*(A22-alpha) + d12*(lA2-uA2); du = d21*(A22-alpha) + d22*(lA2-uA2); l1 = l2; u1 = u2; l2 -= dl; u2 -= du; result = seLR_sf(l, l2, ur, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); lA2 = 1. - SF[L0-1]; result = seU_sf(l, u2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); uA2 = 1. - SF[L0-1]; result = se2_sf(l, l2, u2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in se2_q_crit_class [package spc]"); A22 = 1. - SF[L0-1]; } while ( (fabs(alpha-A22)>1e-9 || fabs(lA2-uA2)>1e-9) && (fabs(l2-l1)>1e-9 || fabs(u2-u1)>1e-9) ); *cl = l2; *cu = u2; Free(SF); return 0; } int se2_q_crit_prerun_SIGMA(double l, int L0, double alpha, double *cl, double *cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error) { double s1, s2, s3, ds, sl1, sl2, sl3, csl, csl0, Pm, Pp, *SF, scale; int result=1; SF = vector(L0); result = se2_q_crit(l, L0, alpha, &csl, &s1, hs, sigma, df1, N, qm1, c_error, a_error); scale = (double)df2 / (double)df1; /* recover m */ scale = 1. + 2./scale; s1 *= scale; csl0 = csl /scale; /*printf("\nunbiased design\n\nKnown ic level:\t cl0 = %.6f,\tcu0 = %.6f\t\t(scale = %.3f)\n\n", csl0, s1, scale);*/ csl = se2fu_q_crit_prerun_SIGMA(l, L0, alpha, s1, csl0, hs, sigma, df1, df2, N, qm1, qm2, truncate, tail_approx, c_error, a_error); /*s1 = seU_q_crit_prerun_SIGMA(l, L0, alpha, hs, sigma, df1, df2, N, qm1, qm2, truncate, tail_approx, c_error, a_error); csl = 0.;*/ /*printf("\n(0)\t cl = %.6f,\t cu = %.6f\n", csl, s1);*/ /*if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s1, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = seU_sf_prerun_SIGMA(l, s1, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pm = 1. - SF[L0-1]; if ( tail_approx ) result = seU_sf_prerun_SIGMA_deluxe(l, s1, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = seU_sf_prerun_SIGMA(l, s1, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pp = 1. - SF[L0-1]; */ if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s1, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, csl, s1, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pm = 1. - SF[L0-1]; if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s1, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, csl, s1, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pp = 1. - SF[L0-1]; sl1 = ( Pp - Pm )/(2.*lmEPS); /*printf("\t\t slope = %.6f\n\n", sl1);*/ if ( sl1 > 0 ) { do { s2 = s1; sl2 = sl1; s1 *= 1.05; csl0 = csl * 1.05; csl = se2fu_q_crit_prerun_SIGMA(l, L0, alpha, s1, csl0, hs, sigma, df1, df2, N, qm1, qm2, truncate, tail_approx, c_error, a_error); if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s1, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, csl, s1, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pm = 1. - SF[L0-1]; if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s1, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, csl, s1, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pp = 1. - SF[L0-1]; sl1 = ( Pp - Pm )/(2.*lmEPS); /*printf("(i)\t cl = %.6f,\t cu = %.6f,\t, slope = %.6f\n", csl, s1, sl1);*/ } while ( sl1 > 0 ); } else { do { s2 = s1; sl2 = sl1; s1 /= 1.05; csl0 = csl / 1.05; csl = se2fu_q_crit_prerun_SIGMA(l, L0, alpha, s1, csl0, hs, sigma, df1, df2, N, qm1, qm2, truncate, tail_approx, c_error, a_error); if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s1, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, csl, s1, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pm = 1. - SF[L0-1]; if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s1, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, csl, s1, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pp = 1. - SF[L0-1]; sl1 = ( Pp - Pm )/(2.*lmEPS); /*printf("(ii)\t cl = %.6f,\t cu = %.6f,\t, slope = %.6f\n", csl, s1, sl1);*/ } while ( sl1 < 0 ); } /*printf("\n");*/ do { s3 = s1 - sl1/(sl2-sl1) * (s2-s1); csl0 = csl * s3/s2; csl = se2fu_q_crit_prerun_SIGMA(l, L0, alpha, s3, csl0, hs, sigma, df1, df2, N, qm1, qm2, truncate, tail_approx, c_error, a_error); if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s3, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, csl, s3, hs, sigma-lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pm = 1. - SF[L0-1]; if ( tail_approx ) result = se2_sf_prerun_SIGMA_deluxe(l, csl, s3, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); else result = se2_sf_prerun_SIGMA(l, csl, s3, hs, sigma+lmEPS, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in se2_q_crit_prerun_SIGMA [package spc]"); Pp = 1. - SF[L0-1]; sl3 = ( Pp - Pm )/(2.*lmEPS); /*printf("(iii)\t cl = %.6f,\t cu = %.6f,\t, slope = %.6f\n", csl, s3, sl3);*/ ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; } while ( fabs(sl3)>a_error && fabs(ds)>c_error ); *cl = csl; *cu = s3; /*printf("\n");*/ Free(SF); return 0; } double seUR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm) { double *a, *g, *w, *z, *t, h, arl, Hij, xl, za, dN, ddf, s2, t0, t1, x0, x1, dummy; int i, j, k, qi, qj, M, Ntilde, NN, ii, it, jj; M = ceil( (log(cl)-log(cu))/log(1.-l) ); Ntilde = ceil( (double)N/(double)M ); NN = M*Ntilde; s2 = sigma*sigma; ddf = (double)df; dN = (double)Ntilde - 1.; a = matrix(NN,NN); g = vector(NN); t = vector(NN); w = vector(qm); z = vector(qm); for(i=0;icu) t1 = cu; for (j=1;j0) { qi = i-1; t0 = cl/pow(1.-l,(double)qi); t1 = t0/(1.-l); if (t1>cu) t1 = cu; if (t01e-10) x0 = sqrt(x0-za); else x0 = 0.; if (t1-za>1e-10) x1 = sqrt(t1-za); else x1 = 0.; } for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; if (j==1) a[ii*NN+jj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1); else { if (fabs(t1-x0)>1e-8) { gausslegendre(qm,x0,x1,z,w); Hij = 0.; for (k=0;k2 ) Hij += w[k] * Tn( (2.*(z[k]*z[k]+za)-t0-t1)/(t1-t0) ,qj-1) * ddf/s2/l * chi(ddf*z[k]*z[k]/s2/l,df) * 2*z[k]; } if (df==1) Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.); if (df==2) Hij /= s2*l; a[ii*NN+jj] = -Hij; } else a[ii*NN+jj] = 0.; } } } for (qi=i;qicu) 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;k2 ) Hij += w[k] * Tn( (2.*(z[k]*z[k]+za)-t0-t1)/(t1-t0) ,qj-1) * ddf/s2/l * chi(ddf*z[k]*z[k]/s2/l,df) * 2*z[k]; } if (df==1) Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.); if (df==2) Hij /= s2*l; if (qi==i) a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1) - Hij; else a[ii*NN+jj] = -Hij; } } } if (i==0) { t0 = cl; t1 = t0/(1.-l); if (t1>cu) t1 = cu; for (qj=1;qj<=Ntilde;qj++) { dummy = (cl-za)/l/s2; if (dummy>0.) { if (df==1) dummy = 2.*PHI( sqrt(dummy), 0. ) - 1.; if (df==2) dummy = 1. - exp( -dummy ); if (df>2) dummy = CHI( df*dummy, df); } else dummy = 0.; a[ii*NN+qj-1] -= dummy * Tn((2.*cl-t0-t1)/(t1-t0),qj-1); } } } } for (j=0;jcu) t1 = cu; if (t0<=hs && hscu ) t1 = cu; for (j=1; j0 ) { qi = i-1; t0 = cl/pow(1.-l,(double)qi); t1 = t0/(1.-l); if ( t1>cu ) t1 = cu; if ( t01e-8) { gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; kcu ) t1 = cu; if ( t00 && j==1 && qi==i ) { for (qj=1; qj<=Ntilde; qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1); } } if ( i>0 && j==1 && qi>i ) { for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = 0.; } } if ( i==0 || j>1 ) { for (qj=1; qj<=Ntilde; qj++) { jj = qi*Ntilde + qj-1; gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0;kcu ) t1 = cu; for (qj=1; qj<=Ntilde; qj++) { dummy = 0.; v = (cl-za)/l; if ( v>0. ) dummy = CHI(ddf/s2*v*v, df); a[ii*NN+qj-1] -= dummy * Tn((2.*cl-t0-t1)/(t1-t0),qj-1); } } } } for ( j=0; jcu ) t1 = cu; if ( t0<=hs && hs1)(zch[i,j]) */ for (i=0; i zreflect) */ for (i=0; i1)(zch[i,j]) */ for (i=0; i zreflect) */ for (i=0; i 1) { for (i=0; imn_plus ) mn_plus = q; } *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < FINALeps ) { *nstop = n; n = nmax + 1; } } /* n > 1 */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(S00); Free(p00); Free(VF0); return 0; } double seUR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0) { double *ww, *zz, b1, b2, ddf2, *SF, rho, s2; int i, m, n, nstop, Nlocal; Nlocal = choose_N_for_se2(l, cl, cu); SF = vector(nmax); ww = vector(qm2); zz = vector(qm2); ddf2 = (double)(df2); b1 = qCHI( truncate/2., df2)/ddf2; b2 = qCHI(1. - truncate/2., df2)/ddf2; gausslegendre(qm2, b1, b2, zz, ww); for (i=0; i 0 ) { for (n=0; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; s2 = zz[qnspecial-1]; j = seUR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 0 ) n--; if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.; } else { for (n=nn; n1)(zch[i,j]) */ for (i=0; i zreflect) */ for (i=0; i 1) { for (i=0; imn_plus ) mn_plus = q; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); /*if ( fabs( (q_plus-q_minus)/q_minus ) 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(p0); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(S00); Free(p00); Free(VF0); return Wq; } double seUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3; L2 = -1.; s2 = hs; do { s1 = s2; L1 = L2; s2 += .2; L2 = seUR_iglarl(l, cl, s2, hs, sigma, df, N, qm); } while ( L2 < L0 ); do { s1 = s2; L1 = L2; s2 -= .02; L2 = seUR_iglarl(l, cl, s2, hs, sigma, df, N, qm); } while ( L2 > L0 ); do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = seUR_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 stdeUR_crit(double l, double L0, double cl, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3; L2 = -1.; s2 = hs; do { s1 = s2; L1 = L2; s2 += .2; L2 = stdeUR_iglarl(l, cl, s2, hs, sigma, df, N, qm); } while ( L2L0 ); do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = stdeUR_iglarl(l, cl, s3, hs, sigma, df, N, qm); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-8 ); return s3; } double seUR_crit_prerun_SIGMA(double l, double L0, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate) { double s1, s2, s3, ds, L1=0., L2=0., L3=0.; s2 = hs; do { s1 = s2; L1 = L2; s2 += .2; L2 = seUR_iglarl_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, N, qm1, qm2, truncate); } while ( L2 < L0 ); do { s1 = s2; L1 = L2; s2 -= .02; L2 = seUR_iglarl_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, N, qm1, qm2, truncate); } while ( L2 > L0 ); do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = seUR_iglarl_prerun_SIGMA(l, cl, s3, hs, sigma, df1, df2, N, qm1, qm2, truncate); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-7 ); return s3; } double seUR_q_crit(double l, int L0, double alpha, double cl, double hs, double sigma, int df, int N, int qm, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = hs; p2 = 1.; do { p1 = p2; s2 += .2; result = seUR_sf(l, cl, s2, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in seUR_q_crit [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha ); s1 = s2 - .2; do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); result = seUR_sf(l, cl, s3, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in seUR_q_crit [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double seUR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cl, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = seUR_q_crit(l, L0, alpha, cl, hs, sigma, df1, N, qm1, c_error, a_error); if ( tail_approx ) result = seUR_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seUR_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seUR_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; if ( p2 > alpha ) { do { p1 = p2; s2 += .2; if ( tail_approx ) result = seUR_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seUR_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seUR_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha ); s1 = s2 - .2; } else { do { p1 = p2; s2 -= .2; if ( tail_approx ) result = seUR_sf_prerun_SIGMA_deluxe(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seUR_sf_prerun_SIGMA(l, cl, s2, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seUR_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 <= alpha && s2 > hs ); s1 = s2 + .2; } do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); if ( tail_approx ) result = seUR_sf_prerun_SIGMA_deluxe(l, cl, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seUR_sf_prerun_SIGMA(l, cl, s3, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seUR_q_crit_prerun_SIGMA [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double seLR_iglarl(double l, double cl, double cu, double hs, double sigma, int df, int N, int qm) { double *a, *g, *w, *z, *t, h, arl, Hij, xl, za, dN, ddf, s2, t0, t1, x0, x1, dummy; int i, j, k, qi, qj, M, Ntilde, NN, ii, it, jj; M = ceil( (log(cl)-log(cu))/log(1.-l) ); Ntilde = ceil( (double)N/(double)M ); NN = M*Ntilde; s2 = sigma*sigma; ddf = (double)df; dN = (double)Ntilde - 1.; a = matrix(NN, NN); g = vector(NN); t = vector(NN); w = vector(qm); z = vector(qm); for(i=0;icu) t1 = cu; for (j=1;j0) { qi = i-1; t0 = cl/pow(1.-l,(double)qi); t1 = t0/(1.-l); if (t1>cu) t1 = cu; if (t01e-10) x0 = sqrt(x0-za); else x0 = 0.; if (t1-za>1e-10) x1 = sqrt(t1-za); else x1 = 0.; } for (qj=1;qj<=Ntilde;qj++) { jj = qi*Ntilde + qj-1; if (j==1) a[ii*NN+jj] = - Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1); else { if (fabs(t1-x0)>1e-8) { gausslegendre(qm,x0,x1,z,w); Hij = 0.; for (k=0;k2 ) Hij += w[k] * Tn( (2.*(z[k]*z[k]+za)-t0-t1)/(t1-t0), qj-1) * ddf/s2/l * chi(ddf*z[k]*z[k]/s2/l,df) * 2*z[k]; } if (df==1) Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.); if (df==2) Hij /= s2*l; a[ii*NN+jj] = -Hij; } else a[ii*NN+jj] = 0.; } } } for (qi=i;qicu) 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;k2 ) Hij += w[k] * Tn( (2.*(z[k]*z[k]+za)-t0-t1)/(t1-t0),qj-1) * ddf/s2/l * chi(ddf*z[k]*z[k]/s2/l,df) * 2*z[k]; } if (df==1) Hij /= gammafn(ddf/2.) * pow(2.*s2*l/ddf,ddf/2.); if (df==2) Hij /= s2*l; if (qi==i) a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1) - Hij; else a[ii*NN+jj] = -Hij; } } } /* "reflection area" */ if (i==0 || j>1) { t0 = cl/pow(1.-l, (double)(M-1.)); t1 = cu; for (qj=1;qj<=Ntilde;qj++) { dummy = (cu-za)/l/s2; if (dummy>0.) { if (df==1) dummy = 2.*( 1. - PHI( sqrt(dummy), 0. ) ); if (df==2) dummy = exp( -dummy ); if (df>2) dummy = 1. - CHI( df*dummy, df); } else dummy = 0.; jj = (M-1)*Ntilde + qj-1; a[ii*NN+jj] -= dummy; } } } } for (j=0;jcu) t1 = cu; if (t0cu ) t1 = cu; for (j=1; j0 ) { qi = i-1; t0 = cl/pow(1.-l,(double)qi); t1 = t0/(1.-l); if ( t1>cu ) t1 = cu; if ( t01e-8 ) { gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; kcu ) t1 = cu; if ( t00 && j==1 && qi==i ) { for (qj=1; qj<=Ntilde; qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = Tn((2.*t[it]-t0-t1)/(t1-t0),qj-1); } } if ( i>0 && j==1 && qi>i ) { for (qj=1; qj<=Ntilde; qj++) { jj = qi*Ntilde + qj-1; a[ii*NN+jj] = 0.; } } if ( i==0 || j>1 ) { for (qj=1; qj<=Ntilde; qj++) { jj = qi*Ntilde + qj-1; gausslegendre(qm, x0, x1, z, w); Hij = 0.; for (k=0; k1 ) { t0 = cl/pow(1.-l, (double)(M-1.)); t1 = cu; for (qj=1; qj<=Ntilde; qj++) { dummy = 0.; v = (cu-za)/l; if ( v>0. ) dummy = 1. - CHI( ddf/s2*v*v, df); jj = (M-1)*Ntilde + qj-1; a[ii*NN+jj] -= dummy; } } } } for (j=0; jcu ) t1 = cu; if ( t0 10.*L0 ) { do { s1 = s2; L1 = L2; s2 -= .01; L2 = lns2ewmaU_arl_igl(l,cl,s2,hs,sigma,df,N); } while ( L2>L0 ); } do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = lns2ewmaU_arl_igl(l,cl,s3,hs,sigma,df,N); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-8 ); return s3; } double lns2ewma2_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N) { double *a, *g, *w, *z, arl, lns, ddf, s2; int i, j; s2 = sigma*sigma; ddf = (double)df; a = matrix(N,N); g = vector(N); w = vector(N); z = vector(N); gausslegendre(N, cl, cu, z, w); for (i=0; i 10.*L0 ) { do { s1 = s2; L1 = L2; s2 += .01; L2 = lns2ewma2_arl_igl(l,s2,cu,hs,sigma,df,N); } while ( L2>L0 ); } do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = lns2ewma2_arl_igl(l,s3,cu,hs,sigma,df,N); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-8 ); return s3; } int lns2ewma2_crit_unbiased(double l, double L0, double *cl, double *cu, double hs, double sigma, int df, int N) { double s1, s2, s3, ds, sl1, sl2, sl3, csl, Lm, Lp, mitte, ddf; ddf = (double)df; /*mitte = -1./ddf - 1./3./ddf/ddf + 2./15./ddf/ddf/ddf/ddf;*/ mitte = E_log_gamma(ddf); csl = lns2ewma2_crit_sym(l, L0, hs, sigma, df, N); s1 = 2.*mitte - csl; Lm = lns2ewma2_arl_igl(l,csl,s1,hs,sigma-lmEPS,df,N); Lp = lns2ewma2_arl_igl(l,csl,s1,hs,sigma+lmEPS,df,N); sl1 = (Lp-Lm)/(2.*lmEPS); /*printf("\n(0)\tcL = %.6f,\tcU = %.6f,\tslope = %.6f\n", csl, s1, sl1);*/ if ( sl1 > 0 ) { do { s2 = s1; sl2 = sl1; s1 -= .05; csl = lns2ewma2_crit_cufix(l,s1,L0,hs,sigma,df,N); Lm = lns2ewma2_arl_igl(l,csl,s1,hs,sigma-lmEPS,df,N); Lp = lns2ewma2_arl_igl(l,csl,s1,hs,sigma+lmEPS,df,N); sl1 = (Lp-Lm)/(2.*lmEPS); /*printf("(1a)\tcL = %.6f,\tcU = %.6f,\tslope = %.6f\n", csl, s1, sl1);*/ } while ( sl1>0. ); } else { do { s2 = s1; sl2 = sl1; s1 += .05; csl = lns2ewma2_crit_cufix(l,s1,L0,hs,sigma,df,N); Lm = lns2ewma2_arl_igl(l,csl,s1,hs,sigma-lmEPS,df,N); Lp = lns2ewma2_arl_igl(l,csl,s1,hs,sigma+lmEPS,df,N); sl1 = (Lp-Lm)/(2.*lmEPS); /*printf("(1b)\tcL = %.6f,\tcU = %.6f,\tslope = %.6f\n", csl, s1, sl1);*/ } while ( sl1<0. ); } do { s3 = s1 - sl1/(sl2-sl1) * (s2-s1); csl = lns2ewma2_crit_cufix(l,s3,L0,hs,sigma,df,N); Lm = lns2ewma2_arl_igl(l,csl,s3,hs,sigma-lmEPS,df,N); Lp = lns2ewma2_arl_igl(l,csl,s3,hs,sigma+lmEPS,df,N); sl3 = (Lp-Lm)/(2.*lmEPS); ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; /*printf("(2)\tcL = %.6f,\tcU = %.6f,\tslope = %.6f\n", csl, s3, sl3);*/ } while ( fabs(sl3)>1e-7 && fabs(ds)>1e-8 ); *cl = csl; *cu = s3; return 0; } double lns2ewma2_crit_sym(double l, double L0, double hs, double sigma, int df, int N) { double cu, cl1, cl2, cl3, L1, L2, L3, dl, mitte, ddf; ddf = (double)df; /*mitte = -1./ddf - 1./3./ddf/ddf + 2./15./ddf/ddf/ddf/ddf;*/ mitte = E_log_gamma(ddf); /*printf("\nsym limits\n");*/ L2 = 1.; cl2 = mitte; do { cl1 = cl2; L1 = L2; cl2 -= .1; cu = 2.*mitte - cl2; L2 = lns2ewma2_arl_igl(l, cl2, cu, hs, sigma, df, N); /*printf("(i)\tcl = %.6f,\tcu = %.6f,\tarl = %.4f\n", cl2, cu, L2);*/ } while ( L21e-7) && (fabs(dl)>1e-8) ); return cl3; } double seLR_sf(double l, double cl, double cu, double hs, double sigma, int df, int N, int nmax, int qm, double *p0) { double *S1s, *S2s, *Pns, *ws, *zs, *zch, *rside, *b, za=0., s2, ddf, xl, xu, dN, Hij, *S00, *p00, *VF0; int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj; M = ceil( (log(cl)-log(cu))/log(1.-l) ); Ntilde = ceil( (double)N/(double)M ); NN = M*Ntilde; s2 = sigma*sigma; ddf = (double)df; dN = (double)Ntilde; ihs = floor( (log(cl) - log(hs))/log(1.-l) ); if ( ihs<0 ) ihs = 0; S1s = matrix(NN,NN); S2s = matrix(NN,NN); ps = ivector(NN); zch = matrix(M,Ntilde); rside = vector(NN+1); b = vector(M+1); ws = vector(qm); zs = vector(qm); Pns = matrix(nmax,NN); S00 = vector(NN); p00 = vector(nmax); VF0 = vector(NN+1); /* interval borders b_i = cl/(1-l)^i */ for (i=0; i1)(zch[i,j]) */ for (i=0; i zreflect) */ for (i=0; i1)(zch[i,j]) */ for (i=0; i zreflect) */ for (i=0; i 1) { for (i=0; imn_plus ) mn_plus = q; } *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < FINALeps ) { *nstop = n; n = nmax + 1; } } /* n > 1 */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(S00); Free(p00); Free(VF0); return 0; } double seLR_sf_prerun_SIGMA_deluxe(double l, double cl, double cu, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate, double *p0) { double *ww, *zz, b1, b2, ddf2, *SF, rho, s2; int i, m, n, nstop, Nlocal; Nlocal = choose_N_for_se2(l, cl, cu); SF = vector(nmax); ww = vector(qm2); zz = vector(qm2); ddf2 = (double)(df2); b1 = qCHI( truncate/2., df2)/ddf2; b2 = qCHI(1. - truncate/2., df2)/ddf2; gausslegendre(qm2, b1, b2, zz, ww); for (i=0; i 0 ) { for (n=0; n nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nstop = n; s2 = zz[qnspecial-1]; j = seLR_sf_deluxe(l, s2*cl, s2*cu, s2*hs, sigma, df1, Nlocal, nmax, qm1, SF, &nstop_, &rho); if ( j != 0 ) warning("trouble with internal [package spc] function seU_sf_deluxe"); if ( nstop_ > nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; if ( nstop_ >= nstop && nsm= nstop && nsm nsm ) nsm = nstop_; if ( nstop_ < 1) nsm = nmax; } } nn = nsm; } for (n=0; n 0 ) n--; if ( p0[n] > 1.-p ) Lp = (double)( n + 2 ); else Lp = 1.; } else { for (n=nn; n1)(zch[i,j]) */ for (i=0; i zreflect) */ for (i=0; i 1) { for (i=0; imn_plus ) mn_plus = q; } enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); /*if ( fabs( (q_plus-q_minus)/q_minus ) 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(Pns); Free(p0); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(S00); Free(p00); Free(VF0); return Wq; } double seLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3; s2 = hs; L2 = 0.; do { s1 = s2; L1 = L2; s2 *= 0.9; L2 = seLR_iglarl(l, s2, cu, hs, sigma, df, N, qm); } while ( L21e-6 && fabs(ds)>1e-7 && s3>0.); return s3; } double stdeLR_crit(double l, double L0, double cu, double hs, double sigma, int df, int N, int qm) { double s1, s2, s3, ds, L1, L2, L3; s2 = hs; L2 = 0.; do { s1 = s2; L1 = L2; s2 -= .1; L2 = stdeLR_iglarl(l, s2, cu, hs, sigma, df, N, qm); } while ( L20. ); do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = stdeLR_iglarl(l, s3, cu, hs, sigma, df, N, qm); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-7 && fabs(ds)>1e-8 && s3>0.); return s3; } double seLR_crit_prerun_SIGMA(double l, double L0, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate) { double s1, s2, s3, ds, L1=0., L2=0., L3=0.; s2 = hs; do { L1 = L2; /*s2 -= .1;*/ s2 *= 0.9; L2 = seLR_iglarl_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate); } while ( L2 < L0 && s2 > 0. ); s1 = s2 + .1; do { s3 = s1 + (L0-L1)/(L2-L1) * (s2-s1); L3 = seLR_iglarl_prerun_SIGMA(l, s3, cu, hs, sigma, df1, df2, N, qm1, qm2, truncate); ds = s3-s2; s1 = s2; L1 = L2; s2 = s3; L2 = L3; } while ( fabs(L0-L3)>1e-6 && fabs(ds)>1e-7 && s3>0.); return s3; } double seLR_q_crit(double l, int L0, double alpha, double cu, double hs, double sigma, int df, int N, int qm, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = hs; p2 = 1.; do { p1 = p2; s2 -= .1; result = seLR_sf(l, s2, cu, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in seLR_q_crit [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha && s2>0.); s1 = s2 + .1; do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); result = seLR_sf(l, s3, cu, hs, sigma, df, N, L0, qm, SF); if ( result != 0 ) warning("trouble in seLR_q_crit [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } double seLR_q_crit_prerun_SIGMA(double l, int L0, double alpha, double cu, double hs, double sigma, int df1, int df2, int N, int qm1, int qm2, double truncate, int tail_approx, double c_error, double a_error) { double s1, s2, s3, ds, p1, p2, p3, *SF; int result=1; SF = vector(L0); s2 = seLR_q_crit(l, L0, alpha, cu, hs, sigma, df1, N, qm1, c_error, a_error); if ( tail_approx ) result = seLR_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seLR_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seLR_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; if ( p2 > alpha ) { do { p1 = p2; s2 -= .1; if ( tail_approx ) result = seLR_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seLR_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seLR_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 > alpha && s2 > 0. ); s1 = s2 + .1; } else { do { p1 = p2; s2 += .1; if ( tail_approx ) result = seLR_sf_prerun_SIGMA_deluxe(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seLR_sf_prerun_SIGMA(l, s2, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seLR_q_crit_prerun_SIGMA [package spc]"); p2 = 1. - SF[L0-1]; } while ( p2 <= alpha && s2 < hs ); s1 = s2 - .1; } do { s3 = s1 + (alpha - p1)/( p2 - p1 ) * (s2-s1); if ( tail_approx ) result = seLR_sf_prerun_SIGMA_deluxe(l, s3, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); else result = seLR_sf_prerun_SIGMA(l, s3, cu, hs, sigma, df1, df2, L0, qm1, qm2, truncate, SF); if ( result != 0 ) warning("trouble in seLR_q_crit_prerun_SIGMA [package spc]"); p3 = 1. - SF[L0-1]; ds = s3 - s2; s1 = s2; p1 = p2; s2 = s3; p2 = p3; } while ( fabs(alpha - p3)>a_error && fabs(ds)>c_error ); Free(SF); return s3; } /* MEWMA: Rigdon (1995a,b) */ /* classical GL Nyström */ double mxewma_arl_0a(double lambda, double ce, int p, double hs, int N) { double *a, *g, *w, *z, arl, rr, r2; int i, j; a = matrix(N, N); g = vector(N); w = vector(N); z = vector(N); ce *= lambda/(2.-lambda); hs *= lambda/(2.-lambda); rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda); r2 = lambda*lambda; gausslegendre(N, 0., ce, z, w); for (i=0; i 1e-10 ) { arl = 1.; for (j=0; j 1e-10 ) { arl = 1.; for (j=0; j 1e-12) - (double)(x < -1e-12); return result; } /* collocation with two halfs in the same step + sin() */ double mxewma_arl_1b(double lambda, double ce, int p, double delta, double hs, int N, int qm0, int qm1) { double rdc, r2, rr, a, b, *z0, *w0, *z1, *w1, *M, *g, dN, term1, term2, term2a, term2b, innen, arl, mean, sigma, eta, u, u2, uu, v, v2, alpha; int r, s, i, j, k, l, N2, N3, p1; N2 = N*N; N3 = N2*N; M = matrix(N2, N2); g = vector(N2); z0 = vector(qm0); w0 = vector(qm0); z1 = vector(qm1); w1 = vector(qm1); ce *= lambda/(2.-lambda); hs *= lambda/(2.-lambda); sigma = lambda/sqrt(ce); rdc = lambda*sqrt(delta/ce); r2 = lambda*lambda; rr = ((1.-lambda)/lambda)*((1.-lambda)/lambda); dN = (double)N; p1 = p - 1; /* canonical Gauss-Legendre nodes and weights */ gausslegendre(qm0, 0., 1., z0, w0); gausslegendre(qm1, 0., 1., z1, w1); for (s=0; s 1. ) upper = 1.; /* substitution sin(alpha) = v */ lower = asin(lower); upper = asin(upper); /* constants for (-1,1) <-> (lower,upper) */ xm = (lower+upper)/2.; xw = (upper-lower)/2.; for (r=0; r 1. ) upper = 1.; /* substitution sin(alpha) = v */ lower = asin(lower); upper = asin(upper); /* constants for (-1,1) <-> (lower,upper) */ xm = (lower+upper)/2.; xw = (upper-lower)/2.; for (r=0; r1e-8 ) && ( fabs(dc)>1e-10) ); return c3; } double mxewma_psi (double lambda, double ce, int p, int N, double *PSI, double *w, double *z) { double *a, rr, r2, rho, norm; int i, j, status, noofit; a = matrix(N, N); ce *= lambda/(2.-lambda); rr = ( (1.-lambda)/lambda ) * ( (1.-lambda)/lambda ); r2 = lambda*lambda; gausslegendre(N, 0., sqrt(ce), z, w); for (i=0; i 1e-10 ) psi0 = 2.*hs * nchi(xi/r2, p, rr*hs*hs) / r2 / zahl; } for (j=0; j 1e-10 ) psi0 = 2.*hs * nchi(xi/r2, p, rr*hs*hs) / r2 / zahl; } for (j=0; j1)(zch[i]) */ for (i=0;i1) { for (i=0;imn_plusx ) mn_plusx = q; } for (i=0;imn_pluss ) mn_pluss = q; } mn_minus = mn_minusx * mn_minuss; mn_plus = mn_plusx * mn_pluss; arl_minus = arl + p0[n-1]/(1.-mn_minus); arl_plus = arl + p0[n-1]/(1.-mn_plus); } arl += p0[n-1]; if ( fabs( (arl_plus-arl_minus)/arl_minus )1)(zch[i]) */ for (i=0;i1)(zch[i]) */ for (i=0;i 1 ) { for (i=0;imn_plusx ) mn_plusx = q; } for (i=0;imn_pluss ) mn_pluss = q; } mn_minus = mn_minusx * mn_minuss; mn_plus = mn_plusx * mn_pluss; *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < FINALeps ) { *nstop = n; n = nmax + 1; } } /* n > 1 */ } /* n=1; n<=nmax; n++ */ Free(p0s); Free(Pns); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(p0x); Free(Pnx); Free(zx); Free(wx); Free(Sx); return 0; } double xseU_Wq(double lx, double ls, double cx, double cs, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm) { double *p0, *Sx, *Pnx, *wx, *zx, *p0x, *S1s, *S2s, *Pns, *ws, *zs, *p0s, q, *zch, *rside, za=0., s2, mn_minus=1., mn_plus=0., mn_minusx, mn_minuss, mn_plusx, mn_pluss, ddf, xl, xu, oben, unten, q_minus=0., q_plus=0., enumerator=0., Wq=0.; int i, j, k, n, *ps; cx *= sqrt( lx/(2.-lx) ); hsx *= sqrt( lx/(2.-lx) ); s2 = sigma*sigma; ddf = (double)df; Sx = matrix(Nx,Nx); wx = vector(Nx); zx = vector(Nx); Pnx = matrix(nmax,Nx); p0x = vector(nmax); S1s = matrix(Ns,Ns); S2s = matrix(Ns,Ns); ps = ivector(Ns); zch = vector(Ns); rside = vector(Ns); ws = vector(qm); zs = vector(qm); Pns = matrix(nmax,Ns); p0s = vector(nmax); p0 = vector(nmax); gausslegendre(Nx,-cx,cx,zx,wx); for (i=0;i1)(zch[i]) */ for (i=0;i 1 ) { for (i=0;imn_plusx ) mn_plusx = q; } for (i=0;imn_pluss ) mn_pluss = q; } mn_minus = mn_minusx * mn_minuss; mn_plus = mn_plusx * mn_pluss; enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(p0); Free(p0s); Free(Pns); Free(zs); Free(ws); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(p0x); Free(Pnx); Free(zx); Free(wx); Free(Sx); return Wq; } int xseU_crit(double lx, double ls, double L0, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm) { double x1, x2, dx, s1, s2, ds, xARL1, xARL2, sARL1, sARL2, xsARL22, xsARL12, xsARL21, f11, f22, f21, f12, d11, d22, d21, d12, nenner, zr=0., c0=-1.; x1 = xe_crit(ewma2,lx,2.*L0,zr,hsx,mu,fix,Nx,c0) - .1; x2 = x1 + .1; s1 = seU_crit(ls,2.*L0,hss,sigma,df,Ns,qm); s2 = s1 + .05; xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx); sARL2 = seU_iglarl(ls,s2,hss,sigma,df,Ns,qm); xsARL22 = xseU_arl(lx,ls,x2,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); do { xARL1 = xe2_iglarl(lx,x1,hsx,mu,Nx); sARL1 = seU_iglarl(ls,s1,hss,sigma,df,Ns,qm); xsARL21 = xseU_arl(lx,ls,x2,s1,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); xsARL12 = xseU_arl(lx,ls,x1,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); /* difference quotient */ f11 = (xsARL22 - xsARL12)/(x2-x1); f12 = (xsARL22 - xsARL21)/(s2-s1); f21 = (xARL2 - xARL1)/(x2-x1); f22 = (sARL1 - sARL2)/(s2-s1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dx = d11*(xsARL22-L0) + d12*(xARL2-sARL2); ds = d21*(xsARL22-L0) + d22*(xARL2-sARL2); x1 = x2; s1 = s2; x2 -= dx; s2 -= ds; xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx); sARL2 = seU_iglarl(ls,s2,hss,sigma,df,Ns,qm); xsARL22 = xseU_arl(lx,ls,x2,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); } while ( (fabs(L0-xsARL22)>1e-6 || fabs(xARL2-sARL2)>1e-6) && (fabs(x2-x1)>1e-8 || fabs(s2-s1)>1e-8) ); *cx = x2; *cs = s2; return 0; } int xseU_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error) { double x1, x2, dx, s1, s2, ds, xp1, xp2, sp1, sp2, xsp22, xsp12, xsp21, f11, f22, f21, f12, d11, d22, d21, d12, nenner, zr=0., *SF; int result=1; SF = vector(L0); x1 = xe_q_crit(ewma2, lx, L0, 1. - sqrt(1.-alpha), zr, hsx, mu, fix, Nx, c_error, a_error); x2 = x1 + .1; s1 = seU_q_crit(ls, L0, 1. - sqrt(1.-alpha), hss, sigma, df, Ns, qm, c_error, a_error); s2 = s1 + .05; result = xe2_sf(lx, x2, hsx, mu, Nx, L0, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling xe2_sf [package spc]"); xp2 = 1. - SF[L0-1]; result = seU_sf(ls, s2, hss, sigma, df, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling seU_sf [package spc]"); sp2 = 1. - SF[L0-1]; result = xseU_sf(lx, ls, x2, s2, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling xseU_sf [package spc]"); xsp22 = 1. - SF[L0-1]; do { result = xe2_sf(lx, x1, hsx, mu, Nx, L0, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling xe2_sf [package spc]"); xp1 = 1. - SF[L0-1]; result = seU_sf(ls, s1, hss, sigma, df, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling seU_sf [package spc]"); sp1 = 1. - SF[L0-1]; result = xseU_sf(lx, ls, x2, s1, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling xseU_sf [package spc]"); xsp21 = 1. - SF[L0-1]; result = xseU_sf(lx, ls, x1, s2, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling xseU_sf [package spc]"); xsp12 = 1. - SF[L0-1]; /* difference quotient */ f11 = (xsp22 - xsp12)/(x2-x1); f12 = (xsp22 - xsp21)/(s2-s1); f21 = (xp2 - xp1)/(x2-x1); f22 = (sp1 - sp2)/(s2-s1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dx = d11*(xsp22-alpha) + d12*(xp2-sp2); ds = d21*(xsp22-alpha) + d22*(xp2-sp2); x1 = x2; s1 = s2; x2 -= dx; s2 -= ds; result = xe2_sf(lx, x2, hsx, mu, Nx, L0, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling xe2_sf [package spc]"); xp2 = 1. - SF[L0-1]; result = seU_sf(ls, s2, hss, sigma, df, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling seU_sf [package spc]"); sp2 = 1. - SF[L0-1]; result = xseU_sf(lx, ls, x2, s2, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xseU_q_crit calling xseU_sf [package spc]"); xsp22 = 1. - SF[L0-1]; } while ( (fabs(alpha - xsp22)>a_error || fabs(xp2-sp2)>a_error) && (fabs(x2-x1)>c_error || fabs(s2-s1)>c_error) ); *cx = x2; *cs = s2; Free(SF); return 0; } int xse2fu_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error) { double x1, x2, dx, s1, s2, ds, xp1, xp2, sp1, sp2, xsp22, xsp12, xsp21, f11, f22, f21, f12, d11, d22, d21, d12, nenner, zr=0., *SF; int result=1; SF = vector(L0); x1 = xe_q_crit(ewma2, lx, L0, 1. - sqrt(1.-alpha), zr, hsx, mu, fix, Nx, c_error, a_error); x2 = x1 + .05; s1 = se2fu_q_crit(ls, L0, 1. - sqrt(1.-alpha), csu, hss, sigma, df, Ns, qm, c_error, a_error); s2 = s1 + .05; result = xe2_sf(lx, x2, hsx, mu, Nx, L0, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xe2_sf [package spc]"); xp2 = 1. - SF[L0-1]; result = se2_sf(ls, s2, csu, hss, sigma, df, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling se2_sf [package spc]"); sp2 = 1. - SF[L0-1]; result = xse2_sf(lx, ls, x2, s2, csu, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xse2_sf [package spc]"); xsp22 = 1. - SF[L0-1]; do { result = xe2_sf(lx, x1, hsx, mu, Nx, L0, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xe2_sf [package spc]"); xp1 = 1. - SF[L0-1]; result = se2_sf(ls, s1, csu, hss, sigma, df, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling se2_sf [package spc]"); sp1 = 1. - SF[L0-1]; result = xse2_sf(lx, ls, x2, s1, csu, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xse2_sf [package spc]"); xsp21 = 1. - SF[L0-1]; result = xse2_sf(lx, ls, x1, s2, csu, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xse2_sf [package spc]"); xsp12 = 1. - SF[L0-1]; /* difference quotient */ f11 = (xsp22 - xsp12)/(x2-x1); f12 = (xsp22 - xsp21)/(s2-s1); f21 = (xp2 - xp1)/(x2-x1); f22 = (sp1 - sp2)/(s2-s1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dx = d11*(xsp22-alpha) + d12*(xp2-sp2); ds = d21*(xsp22-alpha) + d22*(xp2-sp2); x1 = x2; s1 = s2; x2 -= dx; s2 -= ds; result = xe2_sf(lx, x2, hsx, mu, Nx, L0, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xe2_sf [package spc]"); xp2 = 1. - SF[L0-1]; result = se2_sf(ls, s2, csu, hss, sigma, df, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling se2_sf [package spc]"); sp2 = 1. - SF[L0-1]; result = xse2_sf(lx, ls, x2, s2, csu, hsx, hss, mu, sigma, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2fu_q_crit calling xse2_sf [package spc]"); xsp22 = 1. - SF[L0-1]; } while ( (fabs(alpha - xsp22)>a_error || fabs(xp2-sp2)>a_error) && (fabs(x2-x1)>c_error || fabs(s2-s1)>c_error) ); *cx = x2; *csl = s2; Free(SF); return 0; } int xse2_q_crit(double lx, double ls, int L0, double alpha, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int qm, double c_error, double a_error) { double s1, s2, s3, ds, sl1, sl2, sl3, Lm, Lp, x, cl, *SF; int result=1; SF = vector(L0); cl = 0.; result = xseU_q_crit(lx, ls, L0, alpha, &x, &s1, hsx, hss, mu, sigma, df, Nx, Ns, qm, c_error, a_error); if ( result != 0 ) warning("trouble with xse2_q_crit calling xseU_q_crit [package spc]"); result = xseU_sf(lx, ls, x, s1, hsx, hss, mu, sigma-lmEPS, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2_q_crit calling xseU_sf [package spc]"); Lm = 1. - SF[L0-1]; result = xseU_sf(lx, ls, x, s1, hsx, hss, mu, sigma+lmEPS, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2_q_crit calling xseU_sf [package spc]"); Lp = 1. - SF[L0-1]; sl1 = (Lp-Lm)/(2.*lmEPS); s2 = s1 + .15; result = xse2fu_q_crit(lx, ls, L0, alpha, &x, &cl, s2, hsx, hss, mu, sigma, df, Nx, Ns, qm, c_error, a_error); if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2fu_q_crit [package spc]"); result = xse2_sf(lx, ls, x, cl, s2, hsx, hss, mu, sigma-lmEPS, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2_sf [package spc]"); Lm = 1. - SF[L0-1]; result = xse2_sf(lx, ls, x, cl, s2, hsx, hss, mu, sigma+lmEPS, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2_sf [package spc]"); Lp = 1. - SF[L0-1]; sl2 = (Lp-Lm)/(2.*lmEPS); do { s3 = s1 - sl1/(sl2-sl1) * (s2-s1); result = xse2fu_q_crit(lx, ls, L0, alpha, &x, &cl, s3, hsx, hss, mu, sigma, df, Nx, Ns, qm, c_error, a_error); if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2fu_q_crit [package spc]"); result = xse2_sf(lx, ls, x, cl, s3, hsx, hss, mu, sigma-lmEPS, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2_sf [package spc]"); Lm = 1. - SF[L0-1]; result = xse2_sf(lx, ls, x, cl, s3, hsx, hss, mu, sigma+lmEPS, df, Nx, Ns, L0, qm, SF); if ( result != 0 ) warning("trouble with xse2_q_crit calling xse2_sf [package spc]"); Lp = 1. - SF[L0-1]; sl3 = (Lp-Lm)/(2.*lmEPS); ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; } while ( fabs(sl3)>a_error && fabs(ds)>c_error ); *cx = x; *csl = cl; *csu = s3; Free(SF); return 0; } double xse2_arl(double lx, double ls, double cx, double csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm) { double *Sx, *Pnx, *wx, *zx, *p0x, *p0, *S1s, *S2s, *Pns, *ws, *zs, *p0s, q, *zch, *rside, *b, za=0., s2, dN, Hij, arl_minus=0., arl, arl_plus=0., mn_minus=1., mn_plus=0., mn_minusx, mn_minuss, mn_plusx, mn_pluss, ddf, xl, xu, oben, unten; int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj; cx *= sqrt( lx/(2.-lx) ); hsx *= sqrt( lx/(2.-lx) ); M = ceil( (log(csl)-log(csu))/log(1.-ls) ); Ntilde = ceil( (double)Ns/(double)M ); NN = M*Ntilde; s2 = sigma*sigma; ddf = (double)df; dN = (double)Ntilde; ihs = floor( (log(csl)-log(hss))/log(1.-ls) ); if (ihs<0) ihs = 0; Sx = matrix(Nx,Nx); wx = vector(Nx); zx = vector(Nx); Pnx = matrix(nmax,Nx); p0x = vector(nmax); S1s = matrix(NN,NN); S2s = matrix(NN,NN); ps = ivector(NN); zch = matrix(M,Ntilde); rside = vector(NN); b = vector(M+1); ws = vector(qm); zs = vector(qm); Pns = matrix(nmax,NN); p0s = vector(nmax); p0 = vector(nmax); gausslegendre(Nx,-cx,cx,zx,wx); for (i=0;i1)(zch[i,j]) */ for (i=0;i1) { for (i=0;imn_plusx ) mn_plusx = q; } for (i=0;imn_pluss ) mn_pluss = q; } mn_minus = mn_minusx * mn_minuss; mn_plus = mn_plusx * mn_pluss; arl_minus = arl + p0[n-1]/(1.-mn_minus); arl_plus = arl + p0[n-1]/(1.-mn_plus); } arl += p0[n-1]; if ( fabs( (arl_plus-arl_minus)/arl_minus )1)(zch[i,j]) */ for (i=0;i1)(zch[i,j]) */ for (i=0;i1 ) { for (i=0;imn_plusx ) mn_plusx = q; } for (i=0;imn_pluss ) mn_pluss = q; } mn_minus = mn_minusx * mn_minuss; mn_plus = mn_plusx * mn_pluss; *rho = (mn_minus + mn_plus)/2.; if ( fabs(mn_plus - mn_minus) < FINALeps ) { *nstop = n; n = nmax + 1; } } /* n > 1 */ } /* n=1; n<=nmax; n++ */ Free(p0s); Free(Pns); Free(zs); Free(ws); Free(b); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(p0x); Free(Pnx); Free(zx); Free(wx); Free(Sx); return 0; } double xse2_Wq(double lx, double ls, double cx, double csl, double csu, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm) { double *p0, *Sx, *Pnx, *wx, *zx, *p0x, *S1s, *S2s, *Pns, *ws, *zs, *p0s, q, *zch, *rside, *b, za=0., s2, dN, Hij, mn_minus=1., mn_plus=0., mn_minusx, mn_minuss, mn_plusx, mn_pluss, ddf, xl, xu, oben, unten, q_minus=0., q_plus=0., enumerator=0., Wq=0.; int i, j, k, n, *ps, Ntilde, ihs, M, NN, ii, jj; cx *= sqrt( lx/(2.-lx) ); hsx *= sqrt( lx/(2.-lx) ); M = ceil( (log(csl)-log(csu))/log(1.-ls) ); Ntilde = ceil( (double)Ns/(double)M ); NN = M*Ntilde; s2 = sigma*sigma; ddf = (double)df; dN = (double)Ntilde; ihs = floor( (log(csl)-log(hss))/log(1.-ls) ); if (ihs<0) ihs = 0; Sx = matrix(Nx,Nx); wx = vector(Nx); zx = vector(Nx); Pnx = matrix(nmax,Nx); p0x = vector(nmax); S1s = matrix(NN,NN); S2s = matrix(NN,NN); ps = ivector(NN); zch = matrix(M,Ntilde); rside = vector(NN); b = vector(M+1); ws = vector(qm); zs = vector(qm); Pns = matrix(nmax,NN); p0s = vector(nmax); p0 = vector(nmax); gausslegendre(Nx,-cx,cx,zx,wx); for (i=0;i1)(zch[i,j]) */ for (i=0;i1 ) { for (i=0;imn_plusx ) mn_plusx = q; } for (i=0;imn_pluss ) mn_pluss = q; } mn_minus = mn_minusx * mn_minuss; mn_plus = mn_plusx * mn_pluss; enumerator = log( (1.-p)/p0[n-1] ); q_minus = (double)n + enumerator/log(mn_minus); q_plus = (double)n + enumerator/log(mn_plus); if ( fabs( ceil(q_plus) - ceil(q_minus) ) < .5 ) { Wq = ceil(q_plus); n = nmax +1; } } /* n > 1 */ } /* p0[n-1] >= 1.-p */ } /* n=1; n<=nmax; n++ */ Free(p0); Free(p0s); Free(Pns); Free(zs); Free(ws); Free(b); Free(rside); Free(zch); Free(ps); Free(S2s); Free(S1s); Free(p0x); Free(Pnx); Free(zx); Free(wx); Free(Sx); return Wq; } int xse2lu_crit(double lx, double ls, double L0, double *cx, double csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm) { double x1, x2, dx, s1, s2, ds, xARL1, xARL2, sARL1, sARL2, xsARL22, xsARL12, xsARL21, f11, f22, f21, f12, d11, d22, d21, d12, nenner, zr=0, c0=-1.; x1 = xe_crit(ewma2,lx,2.*L0,zr,hsx,mu,fix,Nx,c0) - .1; x2 = x1 + .2; s1 = se2lu_crit(ls,2.*L0,csl,hss,sigma,df,Ns,qm) - .1; s2 = s1 + .2; xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx); sARL2 = se2_iglarl(ls,csl,s2,hss,sigma,df,Ns,qm); xsARL22 = xse2_arl(lx,ls,x2,csl,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); do { xARL1 = xe2_iglarl(lx,x1,hsx,mu,Nx); sARL1 = se2_iglarl(ls,csl,s1,hss,sigma,df,Ns,qm); xsARL21 = xse2_arl(lx,ls,x2,csl,s1,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); xsARL12 = xse2_arl(lx,ls,x1,csl,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); /* difference quotient */ f11 = (xsARL22 - xsARL12)/(x2-x1); f12 = (xsARL22 - xsARL21)/(s2-s1); f21 = (xARL2 - xARL1)/(x2-x1); f22 = (sARL1 - sARL2)/(s2-s1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dx = d11*(xsARL22-L0) + d12*(xARL2-sARL2); ds = d21*(xsARL22-L0) + d22*(xARL2-sARL2); x1 = x2; s1 = s2; x2 -= dx; s2 -= ds; xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx); sARL2 = se2_iglarl(ls,csl,s2,hss,sigma,df,Ns,qm); xsARL22 = xse2_arl(lx,ls,x2,csl,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); } while ( (fabs(L0-xsARL22)>1e-6 || fabs(xARL2-sARL2)>1e-6) && (fabs(x2-x1)>1e-7 || fabs(s2-s1)>1e-7) ); *cx = x2; *csu = s2; return 0; } int xse2fu_crit(double lx, double ls, double L0, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm) { double x1, x2, dx, s1, s2, ds, xARL1, xARL2, sARL1, sARL2, xsARL22, xsARL12, xsARL21, f11, f22, f21, f12, d11, d22, d21, d12, nenner, zr=0, c0=-1.; x1 = xe_crit(ewma2,lx,2.*L0,zr,hsx,mu,fix,Nx,c0) - .1; x2 = x1 + .2; s1 = se2fu_crit(ls,2.*L0,csu,hss,sigma,df,Ns,qm) - .1; s2 = s1 + .2; xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx); sARL2 = se2_iglarl(ls,s2,csu,hss,sigma,df,Ns,qm); xsARL22 = xse2_arl(lx,ls,x2,s2,csu,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); /*printf("cx = %.4f,\tcsk = %.4f,\tcsu = %.4f\t,\txARL = %.2f,\tsARL = %.2f,\txsARL = %.2f\n", x2, s2, csu, xARL2, sARL2, xsARL22);*/ do { xARL1 = xe2_iglarl(lx,x1,hsx,mu,Nx); sARL1 = se2_iglarl(ls,s1,csu,hss,sigma,df,Ns,qm); xsARL21 = xse2_arl(lx,ls,x2,s1,csu,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); xsARL12 = xse2_arl(lx,ls,x1,s2,csu,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); /* difference quotient */ f11 = (xsARL22 - xsARL12)/(x2-x1); f12 = (xsARL22 - xsARL21)/(s2-s1); f21 = (xARL2 - xARL1)/(x2-x1); f22 = (sARL1 - sARL2)/(s2-s1); /* inverse of the difference quotient */ nenner = f11*f22 - f12*f21; d11 = f22/nenner; d12 = -f12/nenner; d21 = -f21/nenner; d22 = f11/nenner; dx = d11*(xsARL22-L0) + d12*(xARL2-sARL2); ds = d21*(xsARL22-L0) + d22*(xARL2-sARL2); x1 = x2; s1 = s2; x2 -= dx; s2 -= ds; xARL2 = xe2_iglarl(lx,x2,hsx,mu,Nx); sARL2 = se2_iglarl(ls,s2,csu,hss,sigma,df,Ns,qm); xsARL22 = xse2_arl(lx,ls,x2,s2,csu,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); /*printf("cx = %.4f,\tcsk = %.4f,\tcsu = %.4f\t,\txARL = %.2f,\tsARL = %.2f,\txsARL = %.2f\n", x2, s2, csu, xARL2, sARL2, xsARL22);*/ } while ( (fabs(L0-xsARL22)>1e-6 || fabs(xARL2-sARL2)>1e-6) && (fabs(x2-x1)>1e-8 || fabs(s2-s1)>1e-8) ); *cx = x2; *csl = s2; return 0; } int xse2_crit(double lx, double ls, double L0, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm) { double s1, s2, s3, ds, sl1, sl2, sl3, Lm, Lp, x, cl; int flag; cl = 0.; flag = xseU_crit(lx,ls,L0,&x,&s1,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); /*printf("cx = %.4f,\tcsl = %.4f,\tcsu = %.4f\n", x, cl, s1);*/ Lm = xseU_arl(lx,ls,x,s1,hsx,hss,mu,sigma-lmEPS,df,Nx,Ns,nmax,qm); Lp = xseU_arl(lx,ls,x,s1,hsx,hss,mu,sigma+lmEPS,df,Nx,Ns,nmax,qm); sl1 = (Lp-Lm)/(2.*lmEPS); s2 = s1 + .15; flag = xse2fu_crit(lx,ls,L0,&x,&cl,s2,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); /*printf("cx = %.4f,\tcsl = %.4f,\tcsu = %.4f\n", x, cl, s2);*/ Lm = xse2_arl(lx,ls,x,cl,s2,hsx,hss,mu,sigma-lmEPS,df,Nx,Ns,nmax,qm); Lp = xse2_arl(lx,ls,x,cl,s2,hsx,hss,mu,sigma+lmEPS,df,Nx,Ns,nmax,qm); sl2 = (Lp-Lm)/(2.*lmEPS); do { s3 = s1 - sl1/(sl2-sl1) * (s2-s1); flag = xse2fu_crit(lx,ls,L0,&x,&cl,s3,hsx,hss,mu,sigma,df,Nx,Ns,nmax,qm); Lm = xse2_arl(lx,ls,x,cl,s3,hsx,hss,mu,sigma-lmEPS,df,Nx,Ns,nmax,qm); Lp = xse2_arl(lx,ls,x,cl,s3,hsx,hss,mu,sigma+lmEPS,df,Nx,Ns,nmax,qm); sl3 = (Lp-Lm)/(2.*lmEPS); /*printf("cx = %.4f,\tcsl = %.4f,\tcsu = %.4f\t,\tslope = %.6f\n", x, cl, s3, sl3);*/ ds = s3-s2; s1 = s2; sl1 = sl2; s2 = s3; sl2 = sl3; } while ( fabs(sl3)>1e-6 && fabs(ds)>1e-7 ); *cx = x; *csl = cl; *csu = s3; return flag; } /* EWMA p under sampling by variables */ /* p = h(mu, sigma) */ double WK_h(double mu, double sigma, double LSL, double USL) { double result; result = PHI( (LSL-mu)/sigma, 0.) + PHI( (mu-USL)/sigma, 0.); return result; } /* d/dmu h(mu, sigma) */ double wk_h_mu(double mu, double sigma, double LSL, double USL) { double result; result = ( -phi( (LSL-mu)/sigma, 0.) + phi( (mu-USL)/sigma, 0.) )/sigma; return result; } /* d/dsigma h(mu, sigma) */ double wk_h_sigma(double mu, double sigma, double LSL, double USL) { double result; result = -( (LSL-mu)*phi( (LSL-mu)/sigma, 0.) + (mu-USL)*phi( (mu-USL)/sigma, 0.) )/sigma/sigma; return result; } /* mu = h^-1(p, sigma) */ double WK_h_invers_mu(double p, double sigma, double LSL, double USL) { double mu, old_mu, merror, perror; mu = sigma*qPHI(p) + USL; perror = WK_h(mu, sigma, LSL, USL) - p; do { old_mu = mu; mu = mu - perror / wk_h_mu(mu, sigma, LSL, USL); merror = mu - old_mu; perror = WK_h(mu, sigma, LSL, USL) - p; } while ( fabs(merror) > 1e-10 && fabs(perror) > 1e-12 ); return mu; } /* sigma = h^-1(p, mu) */ double WK_h_invers_sigma(double p, double mu, double LSL, double USL) { double sigma, old_sigma, serror, perror; sigma = (mu-USL)/qPHI(p); perror = WK_h(mu, sigma, LSL, USL) - p; do { old_sigma = sigma; sigma = sigma - perror / wk_h_sigma(mu, sigma, LSL, USL); serror = sigma - old_sigma; perror = WK_h(mu, sigma, LSL, USL) - p; } while ( fabs(serror) > 1e-10 && fabs(perror) > 1e-12 ); return sigma; } /* alpha, the upper limit of the cdf (and pdf) definite integral */ double wk_alpha(double p, double sigma, int n, double LSL, double USL) { double alpha, dn, zphalf; dn = (double)n; zphalf = qPHI(p/2.); alpha = (dn-1.)/sigma/sigma * (USL-LSL)*(USL-LSL)/4. / (zphalf*zphalf); return alpha; } /* cdf of h(xbar, sigma0=1) for X ~ N(mu, sigma) */ double cdf_phat(double p, double mu, double sigma, int n, double LSL, double USL) { double result, pstar, mu_of_p, dn, centre; dn = (double)n; result = 0.; if ( p >= 1. ) result = 1.; centre = (LSL+USL)/2.; /*pstar = WK_h(centre, sigma, LSL, USL);*/ pstar = WK_h(centre, 1., LSL, USL); if ( pstar < p && p < 1. ) { mu_of_p = WK_h_invers_mu(p, 1., LSL, USL); result = PHI( (mu_of_p - mu)*sqrt(dn)/sigma, 0. ) - PHI( (-mu_of_p - mu)*sqrt(dn)/sigma, 0. ); } return result; } /* pdf of h(xbar, sigma0=1) for X ~ N(mu, sigma) */ double pdf_phat(double p, double mu, double sigma, int n, double LSL, double USL) { double result, pstar, mu_of_p, dn, centre; dn = (double)n; result = 0.; centre = (LSL+USL)/2.; /*pstar = WK_h(centre, sigma, LSL, USL);*/ pstar = WK_h(centre, 1., LSL, USL); if ( pstar < p && p < 1. ) { mu_of_p = WK_h_invers_mu(p, 1., LSL, USL); result = sqrt(dn)*( phi( (mu_of_p - mu)*sqrt(dn)/sigma, 0. ) + phi( (-mu_of_p - mu)*sqrt(dn)/sigma, 0. ) ) / wk_h_mu(mu_of_p, 1., LSL, USL)/sigma; } return result; } /* quantile function of h(xbar, sigma0=1) for X ~ N(mu, sigma) */ double qf_phat(double p0, double mu, double sigma, int n, double LSL, double USL) { double pstar, centre, c1, c2, c3, p1, p2, p3, dc, cstep; centre = (LSL+USL)/2.; pstar = WK_h(centre, sigma, LSL, USL); c2 = pstar; p2 = 0.; cstep = p0/1e3; do { c1 = c2; p1 = p2; c2 += cstep; p2 = cdf_phat(c2, mu, sigma, n, LSL, USL); } while ( p2 < p0 ); if ( c2 <= pstar + cstep + 1e-9 ) { c1 = c2 - cstep/2.; p1 = cdf_phat(c1, mu, sigma, n, LSL, USL); } do { c3 = c1 + ( p0 - p1 )/( p2 - p1 ) * ( c2 - c1 ); p3 = cdf_phat(c3, mu, sigma, n, LSL, USL); dc = c3 - c2; c1 = c2; p1 = p2; c2 = c3; p2 = p3; } while ( fabs( p0 - p3 )>1e-10 && fabs(dc)>1e-10 ); return c3; } /* integrand for cdf of h(xbar, s) for X ~ N(mu, sigma) */ double wk_cdf_i(double y, double p, double mu, double sigma, int n, double LSL, double USL) { double result, alpha, x, s, mu_p, dn, atrim; dn = (double)n; alpha = wk_alpha(p, sigma, n, LSL, USL); atrim = qCHI(0.9999999999, n-1); if ( atrim < alpha ) alpha = atrim; x = alpha - pow(y,2.); s = sigma * sqrt( x/(dn-1.) ); mu_p = WK_h_invers_mu(p, s, LSL, USL); result = PHI( (mu_p-mu)*sqrt(dn)/sigma, 0.) - PHI( (-mu_p-mu)*sqrt(dn)/sigma, 0.); result *= chi(x, n-1) * 2*y; return result; } /* cdf of h(xbar, s) for X ~ N(mu, sigma) */ double cdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes) { double result, alpha, *w, *z, xl, xu, atrim; int i; w = vector(nodes); z = vector(nodes); result = 0.; if ( p >= 1. ) result = 1.; xl = 0.; if ( 0. < p && p < 1. ) { alpha = wk_alpha(p, sigma, n, LSL, USL); atrim = qCHI(0.9999999999, n-1); if ( atrim < alpha ) alpha = atrim; xu = pow(alpha,0.5); gausslegendre(nodes, xl, xu, z, w); for (i=0; i1e-10 && fabs(dc)>1e-10 ); return c3; } /* collocation */ double ewma_phat_arl(double lambda, double ucl, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm) { double *a, *g, *w, *z, arl, Hij, dN, xl, xu, za, ll, pstar, xi, centre; int i, j, k; dN = (double)N; a = matrix(N,N); g = vector(N); w = vector(qm); z = vector(qm); centre = (LSL+USL)/2.; /*pstar = WK_h(centre, sigma, LSL, USL);*/ pstar = WK_h(centre, 1., LSL, USL); for (i=0; i1e-6 && fabs(dc)>1e-12 ); return c3; } double ewma_phat_crit2(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M) { double c1, c2, c3, L1, L2, L3, dc, cstep; c2 = 0.; L2 = 0.; cstep = lambda/10.; do { c1 = c2; L1 = L2; c2 += cstep; L2 = ewma_phat_arl2(lambda, c2, mu, sigma, n, z0, LSL, USL, N, qm, M); } while ( L2 < L0 ); if ( c2 <= cstep + 1e-9 ) { c1 = c2 - cstep/2.; L1 = ewma_phat_arl2(lambda, c1, mu, sigma, n, z0, LSL, USL, N, qm, M); } do { c3 = c1 + ( L0 - L1 )/( L2 - L1 ) * ( c2 - c1 ); L3 = ewma_phat_arl2(lambda, c3, mu, sigma, n, z0, LSL, USL, N, qm, M); dc = c3 - c2; c1 = c2; L1 = L2; c2 = c3; L2 = L3; } while ( fabs( L0 - L3 )>1e-6 && fabs(dc)>1e-12 ); return c3; } int N_of_l(double lambda) { int N; N = 20; if ( lambda < 1e-1 ) N = 40; if ( lambda < 1e-2 ) N = 60; if ( lambda < 1e-3 ) N = 120; if ( lambda < 1e-4 ) N = 200; return N; } double ewma_phat_lambda(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm) { double dn, cS, cE, ldelta, one, L1, L1_, lambda; int i, j, N; lambda = 1.; dn = (double)n; cS = qPHI( 1. - 1./(2.*L0) )/sqrt(dn)*sigma; cE = WK_h( cS, 1., LSL, USL ); L1 = 1./( PHI( (-cS-mu)*sqrt(dn)/sigma, 0.) + 1. - PHI( (cS-mu)*sqrt(dn)/sigma, 0.) ); ldelta = .1; one = 1; for (j=0; j<4; j++) { for (i=0; i<20; i++) { lambda = lambda - ldelta*one; if ( lambda <= min_l ) { lambda = min_l; i = 23; } if ( lambda >= max_l ) { lambda = max_l; i = 23; } N = N_of_l(lambda); cE = ewma_phat_crit(lambda, L0, 0., sigma, n, z0, LSL, USL, N, qm); L1_ = ewma_phat_arl(lambda, cE, mu, sigma, n, z0, LSL, USL, N, qm); if ( L1_ > L1 && i < 23 ) i = 21; L1 = L1_; } ldelta /= 10.; one *= -1.; } if ( i < 23 ) lambda -= 10.*ldelta*one; return lambda; } double ewma_phat_lambda2(double L0, double mu, double sigma, double max_l, double min_l, int n, double z0, double LSL, double USL, int qm, int M) { double dn, cS, cE, ldelta, one, L1, L1_, lambda; int i, j, N; lambda = 1.; dn = (double)n; cS = qPHI( 1. - 1./(2.*L0) )/sqrt(dn)*sigma; cE = WK_h( cS, 1., LSL, USL ); L1 = 1./( PHI( (-cS-mu)*sqrt(dn)/sigma, 0.) + 1. - PHI( (cS-mu)*sqrt(dn)/sigma, 0.) ); ldelta = .1; one = 1; for (j=0; j<4; j++) { for (i=0; i<20; i++) { lambda = lambda - ldelta*one; if ( lambda <= min_l ) { lambda = min_l; i = 23; } if ( lambda >= max_l ) { lambda = max_l; i = 23; } N = N_of_l(lambda); cE = ewma_phat_crit2(lambda, L0, 0., sigma, n, z0, LSL, USL, N, qm, M); L1_ = ewma_phat_arl2 (lambda, cE, mu, sigma, n, z0, LSL, USL, N, qm, M); if ( L1_ > L1 && i < 23 ) i = 21; L1 = L1_; } ldelta /= 10.; one *= -1.; } if ( i < 23 ) lambda -= 10.*ldelta*one; return lambda; } /* attributive EWMA */ double ewma_pU_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[j*NN+i] += -pj; break; case 0: /* round down */ j = (int)floor(zj*d_res); if ( j <= N ) a[j*NN+i] += -pj; break; case 1: /* round up */ j = (int)ceil(zj*d_res); if ( j <= N ) a[j*NN+i] += -pj; break; case 2: /* round to nearest -- round half to even, IEEE 754 */ j = (int)round(zj*d_res); if ( j <= N ) a[j*NN+i] += -pj; break; case 3: /* round to nearest -- round half up */ j = (int)floor(zj*d_res+.5); if ( j <= N ) a[j*NN+i] += -pj; break; case 4: /* distribute */ j = (int)floor(zj*d_res); pju = zj - j/d_res; if ( j <= N ) a[j*NN+i] += -(1.-pju)*pj; if ( j < N ) a[(j+1)*NN+i] += -pju*pj; break; } } ++a[i*NN+i]; } for (j=0; j<=N; j++) g[j] = 1.; /*LU_solve(a, g, NN);*/ solve(&NN, a, g); 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; } double ewma_cU_arl(double lambda, double ucl, double mu, 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<=k_max; k++) { zj = (1.-lambda)*i/d_res + lambda*k; pj = pdf_pois((double)k, mu); switch (round_mode) { case -1: /* round down as probably Gan did */ j = (int)floor(zj*d_res + 1e-9); if ( j <= N ) a[j*NN+i] += -pj; break; case 0: /* round down */ j = (int)floor(zj*d_res); if ( j <= N ) a[j*NN+i] += -pj; break; case 1: /* round up */ j = (int)ceil(zj*d_res); if ( j <= N ) a[j*NN+i] += -pj; break; case 2: /* round to nearest -- round half to even, IEEE 754 */ j = (int)round(zj*d_res); if ( j <= N ) a[j*NN+i] += -pj; break; case 3: /* round to nearest -- round half up */ j = (int)floor(zj*d_res+.5); if ( j <= N ) a[j*NN+i] += -pj; break; case 4: /* distribute */ j = (int)floor(zj*d_res); pju = zj - j/d_res; if ( j <= N ) a[j*NN+i] += -(1.-pju)*pj; if ( j < N ) a[(j+1)*NN+i] += -pju*pj; break; } } ++a[i*NN+i]; } for (j=0; j<=N; j++) g[j] = 1.; /*LU_solve(a, g, NN);*/ solve(&NN, a, g); arl = 1.; k_max = (int)ceil( (ucl+1. - (1.-lambda)*z0)/lambda ); for (k=0; k<=k_max; k++) { zj = (1.-lambda)*z0 + lambda*k; pj = pdf_pois((double)k, mu); 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; } double ewma_pL_arl(double lambda, double lcl, int n, double p, double z0, int d_res, int round_mode, int mid_mode) { double *a, *g, arl, zj=0., pju, pj, zold, dr; int i, j, k, l, u, N, NN/*, k_max*/; dr = (double)d_res; l = (int)floor(lcl*d_res); /*u = (int)qf_binom(.999999, n, p);*/ /*u = (int)qf_binom(.999999, n, p) * d_res;*/ u = n * d_res; N = u - l; 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++) { for (k=0; k<=n; k++) { zold = ( (double)( l + i ) ) / dr; zj = (1.-lambda)*zold + lambda*k; pj = pdf_binom((double)k, n, p); switch (round_mode) { case -1: /* round down as probably Gan did */ j = (int)floor(zj*dr + 1e-9) - l; if ( 0 <= j && j <= u ) a[j*NN+i] += -pj; break; case 0: /* round down */ j = (int)floor(zj*dr) - l; if ( 0 <= j && j <= u ) a[j*NN+i] += -pj; break; case 1: /* round up */ j = (int)ceil(zj*dr) - l; if ( 0 <= j && j <= u ) a[j*NN+i] += -pj; break; case 2: /* round to nearest -- round half to even, IEEE 754 */ j = (int)round(zj*dr) - l; if ( 0 <= j && j <= u ) a[j*NN+i] += -pj; break; case 3: /* round to nearest -- round half up */ j = (int)floor(zj*dr+.5) - l; if ( 0 <= j && j <= u ) a[j*NN+i] += -pj; break; case 4: /* distribute */ j = (int)floor(zj*dr) - l; pju = zj - j/dr; if ( 0 <= j && j <= u ) a[j*NN+i] += -(1.-pju)*pj; if ( 0 < j && j <= u ) a[(j+1)*NN+i] += -pju*pj; break; } } ++a[i*NN+i]; } for (j=0; j<=N; j++) g[j] = 1.; solve(&NN, a, g); arl = 1.; 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*dr + 1e-9) - l; if ( 0 <= j && j <= u ) arl += pj*g[j]; break; case 0: /* round down */ j = (int)floor(zj*dr) - l; if ( 0 <= j && j <= u ) arl += pj*g[j]; break; case 1: /* round up */ j = (int)ceil(zj*dr) - l; if ( 0 <= j && j <= u ) arl += pj*g[j]; break; case 2: /* round to nearest -- round half to even, IEEE 754 */ j = (int)round(zj*dr) - l; if ( 0 <= j && j <= u ) arl += pj*g[j]; break; case 3: /* round to nearest -- round half up */ j = (int)floor(zj*dr+.5) - l; if ( 0 <= j && j <= u ) arl += pj*g[j]; break; case 4: /* distribute */ j = (int)floor(zj*dr) - l; pju = zj - j/dr; if ( 0 <= j && j <= u ) arl += (1.-pju)*pj*g[j]; if ( 0 < j && j <= u ) arl += pju*pj*g[j+1]; break; } } Free(a); Free(g); return arl; } double ewma_cL_arl(double lambda, double lcl, double ucl, double mu, double z0, int d_res, int round_mode, int mid_mode) { double *a, *g, arl, zj=0., pju, pj, zold, dr; int i, j, k, l, u, N, NN, k_max; dr = (double)d_res; l = (int)floor(lcl*d_res); u = (int)ceil(ucl*d_res); k_max = (int)qf_pois(.99999999, mu); N = u - l; 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++) { for (k=0; k<=k_max; k++) { zold = ( (double)( l + i ) ) / dr; zj = (1.-lambda)*zold + lambda*k; pj = pdf_pois((double)k, mu); switch (round_mode) { case -1: /* round down as probably Gan did */ j = (int)floor(zj*dr + 1e-9) - l; if ( 0 <= j && j < N ) a[j*NN+i] += -pj; if ( N <= j ) a[N*NN+i] += -pj; break; case 0: /* round down */ j = (int)floor(zj*dr) - l; if ( 0 <= j && j < N ) a[j*NN+i] += -pj; if ( N <= j ) a[N*NN+i] += -pj; break; case 1: /* round up */ j = (int)ceil(zj*dr) - l; if ( 0 <= j && j < N ) a[j*NN+i] += -pj; if ( N <= j ) a[N*NN+i] += -pj; break; case 2: /* round to nearest -- round half to even, IEEE 754 */ j = (int)round(zj*dr) - l; if ( 0 <= j && j < N ) a[j*NN+i] += -pj; if ( N <= j ) a[N*NN+i] += -pj; break; case 3: /* round to nearest -- round half up */ j = (int)floor(zj*dr+.5) - l; if ( 0 <= j && j < N ) a[j*NN+i] += -pj; if ( N <= j ) a[N*NN+i] += -pj; break; case 4: /* distribute */ j = (int)floor(zj*dr) - l; pju = zj - j/dr; if ( 0 <= j && j < N ) a[j*NN+i] += -(1.-pju)*pj; if ( 0 < j && j < N ) a[(j+1)*NN+i] += -pju*pj; if ( N <= j ) a[N*NN+i] += -pj; break; } } ++a[i*NN+i]; } for (j=0; j<=N; j++) g[j] = 1.; solve(&NN, a, g); arl = 1.; for (k=0; k<=k_max; k++) { zj = (1.-lambda)*z0 + lambda*k; pj = pdf_pois((double)k, mu); switch (round_mode) { case -1: /* round down as probably Gan did */ j = (int)floor(zj*dr + 1e-9) - l; if ( 0 <= j && j < N ) arl += pj*g[j]; if ( N <= j ) arl += pj*g[N]; break; case 0: /* round down */ j = (int)floor(zj*dr) - l; if ( 0 <= j && j < N ) arl += pj*g[j]; if ( N <= j ) arl += pj*g[N]; break; case 1: /* round up */ j = (int)ceil(zj*dr) - l; if ( 0 <= j && j < N ) arl += pj*g[j]; if ( N <= j ) arl += pj*g[N]; break; case 2: /* round to nearest -- round half to even, IEEE 754 */ j = (int)round(zj*dr) - l; if ( 0 <= j && j < N ) arl += pj*g[j]; if ( N <= j ) arl += pj*g[N]; break; case 3: /* round to nearest -- round half up */ j = (int)floor(zj*dr+.5) - l; if ( 0 <= j && j < N ) arl += pj*g[j]; if ( N <= j ) arl += pj*g[N]; break; case 4: /* distribute */ j = (int)floor(zj*dr) - l; pju = zj - j/dr; if ( 0 <= j && j < N ) arl += (1.-pju)*pj*g[j]; if ( 0 < j && j < N ) arl += pju*pj*g[j+1]; if ( N <= j ) arl += pj*g[N]; break; } } Free(a); Free(g); return arl; } double ewma_p2_arl(double lambda, double lcl, 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, N1, N2, NN/*, k_max*/; N2 = (int)ceil(ucl*d_res); N1 = (int)floor(lcl*d_res); N = N2 - N1; 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)*(N1+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) - N1; if ( 0 <= j && j <= N ) a[i*NN+j] += -pj; break; case 0: /* round down */ j = (int)floor(zj*d_res) - N1; if ( 0 <= j && j <= N ) a[i*NN+j] += -pj; break; case 1: /* round up */ j = (int)ceil(zj*d_res) - N1; if ( 0 <= j && 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) - N1; if ( 0 <= j && j <= N ) a[i*NN+j] += -pj; break; case 3: /* round to nearest -- round half up */ j = (int)floor(zj*d_res+.5) - N1; if ( 0 <= j && j <= N ) a[i*NN+j] += -pj; break; case 4: /* distribute */ j = (int)floor(zj*d_res) - N1; pju = zj - j/d_res; if ( 0 <= j && j <= N ) a[i*NN+j] += -(1.-pju)*pj; if ( 0 <= j && 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); /*solve(&NN, a, g);*/ 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) - N1; if ( 0 <= j && j <= N ) arl += pj*g[j]; break; case 0: /* round down */ j = (int)floor(zj*d_res) - N1; if ( 0 <= j && j <= N ) arl += pj*g[j]; break; case 1: /* round up */ j = (int)ceil(zj*d_res) - N1; if ( 0 <= j && j <= N ) arl += pj*g[j]; break; case 2: /* round to nearest -- round half to even, IEEE 754 */ j = (int)round(zj*d_res) - N1; if ( 0 <= j && j <= N ) arl += pj*g[j]; break; case 3: /* round to nearest -- round half up */ j = (int)floor(zj*d_res+.5) - N1; if ( 0 <= j && j <= N ) arl += pj*g[j]; break; case 4: /* distribute */ j = (int)floor(zj*d_res) - N1; pju = zj - j/d_res; if ( 0 <= j && j <= N ) arl += (1.-pju)*pj*g[j]; if ( 0 <= j && j < N ) arl += pju*pj*g[j+1]; break; } } Free(a); Free(g); return arl; } double ewma_c2_arl(double lambda, double lcl, double ucl, double mu, double z0, int d_res, int round_mode, int mid_mode) { double *a, *g, arl, zj=0, lzi=0, pju, pj; int i, j, k, N, N1, N2, NN, k_max; N1 = (int)ceil(lcl*d_res); N2 = (int)floor(ucl*d_res); if ( round_mode == 4 ) { N1 = (int)ceil(lcl*d_res); N2 = (int)floor(ucl*d_res); } N = N2 - N1; 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++) { lzi = (1.-lambda)*(N1+i)/d_res; k_max = (int)ceil( (ucl+1. - lzi)/lambda ); for (k=0; k<=k_max; k++) { zj = lzi + lambda*k; pj = pdf_pois((double)k, mu); switch (round_mode) { case -1: /* round down as probably Gan did */ j = (int)floor(zj*d_res + 1e-9) - N1; if ( 0 <= j && j <= N ) a[i*NN+j] += -pj; break; case 0: /* round down */ j = (int)floor(zj*d_res) - N1; if ( 0 <= j && j <= N ) a[i*NN+j] += -pj; break; case 1: /* round up */ j = (int)ceil(zj*d_res) - N1; if ( 0 <= j && 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) - N1; if ( 0 <= j && j <= N ) a[i*NN+j] += -pj; break; case 3: /* round to nearest -- round half up */ j = (int)floor(zj*d_res+.5) - N1; if ( 0 <= j && j <= N ) a[i*NN+j] += -pj; break; case 4: /* distribute */ j = (int)floor(zj*d_res) - N1; pju = zj - (j+N1)/d_res; if ( 0 <= j && j <= N ) a[i*NN + j] += -(1.-pju)*pj; if ( -1 <= j && 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); /*solve(&NN, a, g);*/ arl = 1.; k_max = (int)ceil( (ucl+1. - (1.-lambda)*z0)/lambda ); for (k=0; k<=k_max; k++) { zj = (1.-lambda)*z0 + lambda*k; pj = pdf_pois((double)k, mu); switch (round_mode) { case -1: /* round down as probably Gan did */ j = (int)floor(zj*d_res + 1e-9) - N1; if ( 0 <= j && j <= N ) arl += pj*g[j]; break; case 0: /* round down */ j = (int)floor(zj*d_res) - N1; if ( 0 <= j && j <= N ) arl += pj*g[j]; break; case 1: /* round up */ j = (int)ceil(zj*d_res) - N1; if ( 0 <= j && j <= N ) arl += pj*g[j]; break; case 2: /* round to nearest -- round half to even, IEEE 754 */ j = (int)round(zj*d_res) - N1; if ( 0 <= j && j <= N ) arl += pj*g[j]; break; case 3: /* round to nearest -- round half up */ j = (int)floor(zj*d_res+.5) - N1; if ( 0 <= j && j <= N ) arl += pj*g[j]; break; case 4: /* distribute */ j = (int)floor(zj*d_res) - N1; pju = zj - (j+N1)/d_res; if ( 0 <= j && j <= N ) arl += (1.-pju)*pj*g[j]; if ( -1 <= j && j < N ) arl += pju*pj*g[j+1]; break; } } Free(a); Free(g); return arl; } /* Markov chain model from Borror / Champ / Rigdon (1998) "Poisson EWMA control charts", JQT 30(4), 352-361 */ double cewma_2_arl(double lambda, double AL, double AU, double mu0, double z0, double mu, int N) { double hL, hU, w, *a, *g, arl; int i, j; a = matrix(N,N); g = vector(N); hL = mu0 - AL * sqrt( lambda*mu0 / (2.-lambda) ); hU = mu0 + AU * sqrt( lambda*mu0 / (2.-lambda) ); w = (hU - hL)/N; for (i=0; i= 0 && j < N ) a[j*N+i] += - pj * px; /*printf("(ii)\ti = %d,\tx = %d,\tj = %d\n", i, x, j);*/ } else { pj = ( zi2 - ( hL + i*w ) ) / w; if ( j >= 0 && j < N ) a[j*N+i] += - pj * px; if ( j >= -1 && j < N-1 ) a[(j+1)*N+i] += - (1.-pj) * px; /*printf("(iv)\ti = %d,\tx = %d,\tj = %d,\tpj = %.4f\n", i, x, j, pj);*/ } } else { if ( hL + (i+1.)*w <= zi2 ) { pj = ( hL + (i+1.)*w - zi1 ) / w; if ( j >= 0 && j < N ) a[j*N+i] += - pj * px; if ( j > 0 && j <= N ) a[(j-1)*N+i] += - (1.-pj) * px; /*printf("(iii)\ti = %d,\tx = %d,\tj = %d,\tpj = %.4f\n", i, x, j, pj);*/ } else { pj = 0.; /* should not be possible */ /*printf("(i)\tshould not happen.\n");*/ } } /*printf("i = %d,\tx = %d,\tj = %d,\tpj = %.4f,\tzj = %.4f\n", i, x, j, pj, zj);*/ } /*printf("\n\n");*/ ++a[i*N+i]; } for (j=0; j= 0 && j < N ) arl += pj * px * g[j]; /*printf("(i)\tx = %d,\tj = %d\n", x, j);*/ } else { pj = ( zi2 - Li ) / w; if ( j >= 0 && j < N ) arl += pj * px * g[j]; if ( j >= -1 && j < N-1 ) arl += (1.-pj) * px * g[j+1]; /*printf("(ii)\tx = %d,\tj = %d,\tpj = %.4f\t(+)\n", x, j, pj);*/ } } else { if ( Ui <= zi2 ) { pj = ( Ui - zi1 ) / w; if ( j >= 0 && j < N ) arl += pj * px * g[j]; if ( j > 0 && j <= N ) arl += (1.-pj) * px * g[j-1]; /*printf("(iii)\tx = %d,\tj = %d,\tpj = %.4f\t(-)\n", x, j, pj);*/ } else { pj = 0.; /* should not be possible */ /*printf("(iv)\tx = %d,\tj = %d\t---\tshould not happen.\n", x, j);*/ } } /*printf("\n");*/ } /*printf("\nfinal solution arl = %.6f\n\n", arl);*/ Free(a); Free(g); return arl; } double cewma_2_Warl_new(double lambda, double AL, double AU, double mu0, double z0, double mu, int N, int nmax) { double hL, hU, w, *z, *Sm, *Pn, *p0, *ap, ratio, arl_minus=0., arl=1., arl_plus=0., mn_minus=1., mn_plus=0., zi, zj, zi1, zi2, pj, px, Li, Ui; int i, j, n, x, x0, x1; Sm = matrix(N,N); z = vector(N); ap = vector(N); Pn = matrix(nmax,N); p0 = vector(nmax); hL = mu0 - AL * sqrt( lambda*mu0 / (2.-lambda) ); hU = mu0 + AU * sqrt( lambda*mu0 / (2.-lambda) ); w = (hU - hL)/N; for (i=0; i= 0 && j < N ) Sm[i*N+j] += pj * px; } else { pj = ( zi2 - ( hL + i*w ) ) / w; if ( j >= 0 && j < N ) Sm[i*N+j] += pj * px; if ( j >= -1 && j < N-1 ) Sm[(i+1)*N+j] += (1.-pj) * px; } } else { if ( hL + (i+1.)*w <= zi2 ) { pj = ( hL + (i+1.)*w - zi1 ) / w; if ( j >= 0 && j < N ) Sm[i*N+j] += pj * px; if ( j > 0 && j <= N ) Sm[(i-1)*N+j] += (1.-pj) * px; } else { pj = 0.; /* should not be possible */ } } } } /* 'assistant' vector */ zi = (1.-lambda) * z0; x0 = (int)floor( (hL-zi)/lambda ) - 3; if ( x0 < 0 ) x0 = 0; x1 = (int)ceil( (hU-zi)/lambda ) + 3; i = (int)ceil( (z0-hL)/w ) - 1; Li = z0 - w/2.; Ui = z0 + w/2.; for (x=x0; x<=x1; x++) { px = pdf_pois((double)x, mu); zj = zi + (double)x*lambda; j = (int)ceil( (zj-hL)/w ) - 1; zi1 = ( hL + j*w - (double)x*lambda ) / (1.-lambda); zi2 = ( hL + (j+1.)*w - (double)x*lambda ) / (1.-lambda); if ( zi1 <= Li ) { if ( Ui <= zi2 ) { pj = 1.; if ( j >= 0 && j < N ) ap[j] += pj * px; } else { pj = ( zi2 - Li ) / w; if ( j >= 0 && j < N ) ap[j] += pj * px; if ( j >= -1 && j < N-1 ) ap[j+1] += (1.-pj) * px; } } else { if ( Ui <= zi2 ) { pj = ( Ui - zi1 ) / w; if ( j >= 0 && j < N ) ap[j] += pj * px; if ( j > 0 && j <= N ) ap[j-1] += (1.-pj) * px; } else { pj = 0.; /* should not be possible */ } } } arl = 1.; for (n=1; n<=nmax; n++) { if (n==1) for (i=0; i1) { 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 )= 0 && j < N ) a[j*N+i] += pj * px; } else { pj = ( zi2 - ( hL + i*w ) ) / w; if ( j >= 0 && j < N ) a[j*N+i] += pj * px; if ( j >= -1 && j < N-1 ) a[(j+1)*N+i] += (1.-pj) * px; } } else { if ( hL + (i+1.)*w <= zi2 ) { pj = ( hL + (i+1.)*w - zi1 ) / w; if ( j >= 0 && j < N ) a[j*N+i] += pj * px; if ( j > 0 && j <= N ) a[(j-1)*N+i] += (1.-pj) * px; } else { pj = 0.; /* should not be possible */ } } } } pmethod(N, a, &status, &rho, psi, &noofit); norm = 0.; for (j=0; j= 0 && j < N ) a[j*N+i] += - pj * px; } else { pj = ( zi2 - ( hL + i*w ) ) / w; if ( j >= 0 && j < N ) a[j*N+i] += - pj * px; if ( j >= -1 && j < N-1 ) a[(j+1)*N+i] += - (1.-pj) * px; } } else { if ( hL + (i+1.)*w <= zi2 ) { pj = ( hL + (i+1.)*w - zi1 ) / w; if ( j >= 0 && j < N ) a[j*N+i] += - pj * px; if ( j > 0 && j <= N ) a[(j-1)*N+i] += - (1.-pj) * px; } else { pj = 0.; /* should not be possible */ } } } ++a[i*N+i]; } for (j=0; j= 0 && j < N ) a[j*N+i] += - pj * px; } else { pj = ( zi2 - (hL+i*w) ) / w; qj = 1. - pj; if ( j >= 0 && j < N ) { if ( j==0 ) pj *= (1.-gammaL); if ( j==N-1 ) pj *= (1.-gammaU); a[j*N+i] += - pj * px; } if ( j >= -1 && j < N-1 ) { if ( j==-1 ) qj *= (1.-gammaL); if ( j==N-2 ) qj *= (1.-gammaU); a[(j+1)*N+i] += - qj * px; } } } else { if ( hL + (i+1.)*w <= zi2 ) { pj = ( hL + (i+1.)*w - zi1 ) / w; qj = 1. - pj; if ( j >= 0 && j < N ) { if ( j==0 ) pj *= (1.-gammaL); if ( j==N-1 ) pj *= (1.-gammaU); a[j*N+i] += - pj * px; } if ( j > 0 && j <= N ) { if ( j==1 ) qj *= (1.-gammaL); if ( j==N ) qj *= (1.-gammaU); a[(j-1)*N+i] += - qj * px; } } else { pj = 0.; /* should not be possible */ } } } ++a[i*N+i]; } for (j=0; j= 0 && j < N ) arl += pj * px * g[j]; } else { pj = ( zi2 - (hL+i*w) ) / w; qj = 1. - pj; if ( j >= 0 && j < N ) { if ( j==0 ) pj *= (1.-gammaL); if ( j==N-1 ) pj *= (1.-gammaU); arl += pj * px * g[j]; } if ( j >= -1 && j < N-1 ) { if ( j==-1 ) qj *= (1.-gammaL); if ( j==N-2 ) qj *= (1.-gammaU); arl += qj * px * g[j+1]; } } } else { if ( hL + (i+1.)*w <= zi2 ) { pj = ( hL+(i+1.)*w - zi1 ) / w; qj = 1. - pj; if ( j >= 0 && j < N ) { if ( j==0 ) pj *= (1.-gammaL); if ( j==N-1 ) pj *= (1.-gammaU); arl += pj * px * g[j]; } if ( j > 0 && j <= N ) { if ( j==1 ) qj *= (1.-gammaL); if ( j==N ) qj *= (1.-gammaU); arl += qj * px * g[j-1]; } } else { pj = 0.; /* should not be possible */ } } } Free(a); Free(g); return arl; } double cewma_U_arl(double lambda, double AU, double mu0, double z0, double mu, int N) { double hL, hU, w, *a, *g, arl; int i, j; a = matrix(N,N); g = vector(N); hL = 0.; hU = mu0 + AU * sqrt( lambda*mu0 / (2.-lambda) ); w = hU/N; for (i=0; i= 0 && j < N ) a[j*N+i] += - pj * px; /*printf("(ii)\ti = %d,\tx = %d,\tj = %d\n", i, x, j);*/ } else { pj = ( zi2 - ( hL + i*w ) ) / w; if ( j >= 0 && j < N ) a[j*N+i] += - pj * px; if ( j >= -1 && j < N-1 ) a[(j+1)*N+i] += - (1.-pj) * px; /*printf("(iv)\ti = %d,\tx = %d,\tj = %d,\tpj = %.4f\n", i, x, j, pj);*/ } } else { if ( hL + (i+1.)*w <= zi2 ) { pj = ( hL + (i+1.)*w - zi1 ) / w; if ( j >= 0 && j < N ) a[j*N+i] += - pj * px; if ( j > 0 && j <= N ) a[(j-1)*N+i] += - (1.-pj) * px; /*printf("(iii)\ti = %d,\tx = %d,\tj = %d,\tpj = %.4f\n", i, x, j, pj);*/ } else { pj = 0.; /* should not be possible */ /*printf("(i)\tshould not happen.\n");*/ } } /*printf("i = %d,\tx = %d,\tj = %d,\tmj = %.4f,\tpj = %.4f,\tzj = %.4f,\tzj-mj = %.4f\n", i, x, j, mj, pj, zj, zj-mj);*/ } /*printf("\n\n");*/ ++a[i*N+i]; } for (j=0; j= 0 && j < N ) arl += pj * px * g[j]; } else { pj = ( zi2 - ( hL + i*w ) ) / w; if ( j >= 0 && j < N ) arl += pj * px * g[j]; if ( j >= -1 && j < N-1 ) arl += (1.-pj) * px * g[j+1]; } } else { if ( hL + (i+1.)*w <= zi2 ) { pj = ( hL + (i+1.)*w - zi1 ) / w; if ( j >= 0 && j < N ) arl += pj * px * g[j]; if ( j > 0 && j <= N ) arl += (1.-pj) * px * g[j-1]; } else { pj = 0.; /* should not be possible */ } } } Free(a); Free(g); return arl; } double cewma_L_arl(double lambda, double AL, double AU, double mu0, double z0, double mu, int N) { double hL, hU, w, *a, *g, arl; int i, j; a = matrix(N,N); g = vector(N); hL = mu0 - AL * sqrt( lambda*mu0 / (2.-lambda) ); hU = mu0 + AU * sqrt( lambda*mu0 / (2.-lambda) ); w = (hU - hL)/N; for (i=0; i= 0 && j < N ) a[j*N+i] += - pj * px; /*printf("(ii)\ti = %d,\tx = %d,\tj = %d\n", i, x, j);*/ } else { pj = ( zi2 - ( hL + i*w ) ) / w; if ( j >= 0 && j < N ) a[j*N+i] += - pj * px; if ( j >= -1 && j < N-1 ) a[(j+1)*N+i] += - (1.-pj) * px; if ( j >= -1 && j == N-1 ) a[(N-1)*N+i] += - (1.-pj) * px; /*printf("(iv)\ti = %d,\tx = %d,\tj = %d,\tpj = %.4f\n", i, x, j, pj);*/ } } else { if ( hL + (i+1.)*w <= zi2 ) { pj = ( hL + (i+1.)*w - zi1 ) / w; if ( j >= 0 && j < N ) a[j*N+i] += - pj * px; if ( j > 0 && j <= N ) a[(j-1)*N+i] += - (1.-pj) * px; /*printf("(iii)\ti = %d,\tx = %d,\tj = %d,\tpj = %.4f\n", i, x, j, pj);*/ } else { pj = 0.; /* should not be possible */ /*printf("(i)\tshould not happen.\n");*/ } } } a[(N-1)*N+i] += - ( 1. - cdf_pois( (double)x1-1., mu) ); ++a[i*N+i]; } for (j=0; j= 0 && j < N ) arl += pj * px * g[j]; } else { pj = ( zi2 - ( hL + i*w ) ) / w; if ( j >= 0 && j < N ) arl += pj * px * g[j]; if ( j >= -1 && j < N-1 ) arl += (1.-pj) * px * g[j+1]; if ( j >= -1 && j == N-1 ) arl += (1.-pj) * px * g[N-1]; } } else { if ( hL + (i+1.)*w <= zi2 ) { pj = ( hL + (i+1.)*w - zi1 ) / w; if ( j >= 0 && j < N ) arl += pj * px * g[j]; if ( j > 0 && j <= N ) arl += (1.-pj) * px * g[j-1]; } else { pj = 0.; /* should not be possible */ } } } arl += ( 1. - cdf_pois( (double)x1-1., mu) ) * g[N-1]; Free(a); Free(g); return arl; } double cewma_U_crit(double lambda, double L0, double mu0, double z0, int N, int jmax) { double A, A1, L1; int j, dA; A1 = floor(mu0); if ( A1 < 1. ) A1 = 1.; L1 = 1.; A = 1.; for (j=1; j<=(int)A1; j++) { A = (double)j; L1 = cewma_U_arl(lambda, A, mu0, z0, mu0, N); if ( L1 > L0 ) j = (int)A1 + 1; } A1 = A; if ( L1 > L0 ) { for (j=1; j<=jmax; j++) { for (dA=1; dA<20; dA++) { A = A1 + dA / pow(-10., (double)j); L1 = cewma_U_arl(lambda, A, mu0, z0, mu0, N); if ( ( fmod((double)j, 2.) > 0. && L1 < L0 ) || ( fmod((double)j, 2.) < 1. && L1 > L0 ) ) dA = 20; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } else { for (j=1; j<=jmax; j++) { for (dA=1; dA<20; dA++) { A = A1 - dA / pow(-10., (double)j); L1 = cewma_U_arl(lambda, A, mu0, z0, mu0, N); if ( ( fmod((double)j, 2.) < 1. && L1 < L0 ) || ( fmod((double)j, 2.) > 0. && L1 > L0 ) ) dA = 20; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } return A; } double cewma_U_crit_new(double lambda, double L0, double mu0, double z0, int N, int jmax) { double A, A1, L1; int j, dA; A1 = floor(mu0); if ( A1 < 1. ) A1 = 1.; L1 = 1.; A = 1.; for (j=1; j<=(int)A1; j++) { A = (double)j; L1 = cewma_U_arl_new(lambda, A, mu0, z0, mu0, N); if ( L1 > L0 ) j = (int)A1 + 1; } A1 = A; if ( L1 > L0 ) { for (j=1; j<=jmax; j++) { for (dA=1; dA<20; dA++) { A = A1 + dA / pow(-10., (double)j); L1 = cewma_U_arl_new(lambda, A, mu0, z0, mu0, N); if ( ( fmod((double)j, 2.) > 0. && L1 < L0 ) || ( fmod((double)j, 2.) < 1. && L1 > L0 ) ) dA = 20; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } else { for (j=1; j<=jmax; j++) { for (dA=1; dA<20; dA++) { A = A1 - dA / pow(-10., (double)j); L1 = cewma_U_arl_new(lambda, A, mu0, z0, mu0, N); if ( ( fmod((double)j, 2.) < 1. && L1 < L0 ) || ( fmod((double)j, 2.) > 0. && L1 > L0 ) ) dA = 20; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } return A; } double cewma_L_crit(double lambda, double L0, double AU, double mu0, double z0, int N, int jmax) { double A, A1, L1; int j, dA; A1 = floor(mu0); if ( A1 < 1. ) A1 = 1.; L1 = 1.; A = 1.; for (j=1; j<=(int)A1; j++) { A = (double)j; L1 = cewma_L_arl(lambda, A, AU, mu0, z0, mu0, N); if ( L1 > L0 ) j = (int)A1 + 1; } A1 = A; if ( L1 > L0 ) { for (j=1; j<=jmax; j++) { for (dA=1; dA<20; dA++) { A = A1 + dA / pow(-10., (double)j); L1 = cewma_L_arl(lambda, A, AU, mu0, z0, mu0, N); if ( ( fmod((double)j, 2.) > 0. && L1 < L0 ) || ( fmod((double)j, 2.) < 1. && L1 > L0 ) ) dA = 20; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } else { for (j=1; j<=jmax; j++) { for (dA=1; dA<20; dA++) { A = A1 - dA / pow(-10., (double)j); L1 = cewma_L_arl(lambda, A, AU, mu0, z0, mu0, N); if ( ( fmod((double)j, 2.) < 1. && L1 < L0 ) || ( fmod((double)j, 2.) > 0. && L1 > L0 ) ) dA = 20; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } return A; } double cewma_L_crit_new(double lambda, double L0, double AU, double mu0, double z0, int N, int jmax) { double A, A1, L1, ALmax; int j, dA; ALmax = mu0 / sqrt( lambda*mu0 / (2.-lambda) ) - 0.00000000001; A1 = floor(mu0); if ( A1 < 1. ) A1 = 1.; if ( A1 > ALmax ) A1 = floor(ALmax); L1 = 1.; A = 1.; /*printf("\nALmax = %.4f,\tA1 = %.4f\n\n", ALmax, A1);*/ for (j=1; j<=(int)A1; j++) { A = (double)j; L1 = cewma_L_arl_new(lambda, A, AU, mu0, z0, mu0, N); /*printf("!!!A = %.4f,\tL1 = %.6f\n", A, L1);*/ if ( L1 > L0 ) j = (int)A1 + 1; } A1 = A; if ( L1 > L0 ) { for (j=1; j<=jmax; j++) { for (dA=1; dA<30; dA++) { A = A1 + dA / pow(-10., (double)j); if ( A > ALmax ) { A = ALmax - 1./pow(10., (double)j+1); dA = 30; } L1 = cewma_L_arl_new(lambda, A, AU, mu0, z0, mu0, N); /*printf("---A = %.4f,\tL1 = %.6f\n", A, L1);*/ if ( ( fmod((double)j, 2.) > 0. && L1 < L0 ) || ( fmod((double)j, 2.) < 1. && L1 > L0 ) ) dA = 30; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } else { for (j=1; j<=jmax; j++) { for (dA=1; dA<30; dA++) { A = A1 - dA / pow(-10., (double)j); if ( A > ALmax ) { A = ALmax - 1./pow(10., (double)j+1); dA = 30; } L1 = cewma_L_arl_new(lambda, A, AU, mu0, z0, mu0, N); /*printf("+++A = %.4f,\tL1 = %.6f\n", A, L1);*/ if ( ( fmod((double)j, 2.) < 1. && L1 < L0 ) || ( fmod((double)j, 2.) > 0. && L1 > L0 ) ) dA = 30; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } return A; } double cewma_2_crit_sym(double lambda, double L0, double mu0, double z0, int N, int jmax) { double A, A1, L1; int j, dA; A1 = floor(mu0); if ( A1 < 1. ) A1 = 1.; L1 = 1.; A = 1.; for (j=1; j<=(int)A1; j++) { A = (double)j; L1 = cewma_2_arl(lambda, A, A, mu0, z0, mu0, N); if ( L1 > L0 ) j = (int)A1 + 1; } A1 = A; if ( L1 > L0 ) { for (j=1; j<=jmax; j++) { for (dA=1; dA<20; dA++) { A = A1 + dA / pow(-10., (double)j); L1 = cewma_2_arl(lambda, A, A, mu0, z0, mu0, N); if ( ( fmod((double)j, 2.) > 0. && L1 < L0 ) || ( fmod((double)j, 2.) < 1. && L1 > L0 ) ) dA = 20; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } else { for (j=1; j<=jmax; j++) { for (dA=1; dA<20; dA++) { A = A1 - dA / pow(-10., (double)j); L1 = cewma_2_arl(lambda, A, A, mu0, z0, mu0, N); if ( ( fmod((double)j, 2.) < 1. && L1 < L0 ) || ( fmod((double)j, 2.) > 0. && L1 > L0 ) ) dA = 20; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } return A; } double cewma_2_crit_sym_new(double lambda, double L0, double mu0, double z0, int N, int jmax) { double A, A1, L1; int j, dA; A1 = floor(mu0); if ( A1 < 1. ) A1 = 1.; L1 = 1.; A = 1.; for (j=1; j<=(int)A1; j++) { A = (double)j; L1 = cewma_2_arl_new(lambda, A, A, mu0, z0, mu0, N); /*printf("!!!A = %.4f,\tL1 = %.6f\n", A, L1);*/ if ( L1 > L0 ) j = (int)A1 + 1; } A1 = A; if ( L1 > L0 ) { for (j=0; j<=jmax; j++) { for (dA=1; dA<20; dA++) { A = A1 - dA / pow(-10., (double)j); L1 = cewma_2_arl_new(lambda, A, A, mu0, z0, mu0, N); /*printf("+++A = %.4f,\tL1 = %.6f\n", A, L1);*/ if ( ( fmod((double)j, 2.) < 1. && L1 < L0 ) || ( fmod((double)j, 2.) > 0. && L1 > L0 ) ) dA = 20; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } else { for (j=0; j<=jmax; j++) { for (dA=1; dA<20; dA++) { A = A1 + dA / pow(-10., (double)j); L1 = cewma_2_arl_new(lambda, A, A, mu0, z0, mu0, N); /*printf("---A = %.4f,\tL1 = %.6f\n", A, L1);*/ if ( ( fmod((double)j, 2.) > 0. && L1 < L0 ) || ( fmod((double)j, 2.) < 1. && L1 > L0 ) ) dA = 20; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } return A; } double cewma_2_crit_AL(double lambda, double L0, double AU, double mu0, double z0, int N, int jmax) { double A, A1, L1, ALmax; int j, dA; ALmax = mu0 / sqrt( lambda*mu0 / (2.-lambda) ) - 0.00000000001; A1 = AU; A = A1; L1 = cewma_2_arl(lambda, A1, AU, mu0, z0, mu0, N); if ( L1 > L0 ) { for (j=1; j<=jmax; j++) { for (dA=1; dA<30; dA++) { A = A1 + dA / pow(-10., (double)j); if ( A > ALmax ) { A = ALmax - 1./pow(10., (double)j+1); dA = 30; } L1 = cewma_2_arl(lambda, A, AU, mu0, z0, mu0, N); if ( ( fmod((double)j, 2.) > 0. && L1 < L0 ) || ( fmod((double)j, 2.) < 1. && L1 > L0 ) ) dA = 30; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } else { for (j=1; j<=jmax; j++) { for (dA=1; dA<30; dA++) { A = A1 - dA / pow(-10., (double)j); if ( A > ALmax ) { A = ALmax - 1./pow(10., (double)j+1); dA = 30; } L1 = cewma_2_arl(lambda, A, AU, mu0, z0, mu0, N); if ( ( fmod((double)j, 2.) < 1. && L1 < L0 ) || ( fmod((double)j, 2.) > 0. && L1 > L0 ) ) dA = 30; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } return A; } double cewma_2_crit_AL_new(double lambda, double L0, double AU, double mu0, double z0, int N, int jmax) { double A, A1, L1, ALmax;; int j, dA; ALmax = mu0 / sqrt( lambda*mu0 / (2.-lambda) ) - 0.00000000001; A1 = AU; A = A1; L1 = cewma_2_arl_new(lambda, A1, AU, mu0, z0, mu0, N); if ( L1 > L0 ) { for (j=1; j<=jmax; j++) { for (dA=1; dA<30; dA++) { A = A1 + dA / pow(-10., (double)j); if ( A > ALmax ) { A = ALmax - 1./pow(10., (double)j+1); dA = 30; } L1 = cewma_2_arl_new(lambda, A, AU, mu0, z0, mu0, N); if ( ( fmod((double)j, 2.) > 0. && L1 < L0 ) || ( fmod((double)j, 2.) < 1. && L1 > L0 ) ) dA = 30; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } else { for (j=1; j<=jmax; j++) { for (dA=1; dA<30; dA++) { A = A1 - dA / pow(-10., (double)j); if ( A > ALmax ) { A = ALmax - 1./pow(10., (double)j+1); dA = 30; } L1 = cewma_2_arl_new(lambda, A, AU, mu0, z0, mu0, N); if ( ( fmod((double)j, 2.) < 1. && L1 < L0 ) || ( fmod((double)j, 2.) > 0. && L1 > L0 ) ) dA = 30; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } return A; } double cewma_2_crit_AU(double lambda, double L0, double AL, double mu0, double z0, int N, int jmax) { double A, A1, L1; int j, dA; /*printf("\n\nGet AU for AL = %.4f and L0 = %.1f\n\n", AL, L0); */ A1 = AL; A = A1; L1 = cewma_2_arl(lambda, AL, A1, mu0, z0, mu0, N); /*printf("\n***A1 = %.4f,\tL1 = %.6f\n\n", A1, L1);*/ if ( L1 > L0 ) { for (j=1; j<=jmax; j++) { for (dA=1; dA<20; dA++) { A = A1 + dA / pow(-10., (double)j); L1 = cewma_2_arl(lambda, AL, A, mu0, z0, mu0, N); /*printf("---A = %.4f,\tL1 = %.6f\n", A, L1);*/ if ( ( fmod((double)j, 2.) > 0. && L1 > L0 ) || ( fmod((double)j, 2.) < 1. && L1 < L0 ) ) dA = 20; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } else { for (j=1; j<=jmax; j++) { for (dA=1; dA<20; dA++) { A = A1 - dA / pow(-10., (double)j); L1 = cewma_2_arl(lambda, AL, A, mu0, z0, mu0, N); /*printf("+++A = %.4f,\tL1 = %.6f\n", A, L1);*/ if ( ( fmod((double)j, 2.) < 1. && L1 < L0 ) || ( fmod((double)j, 2.) > 0. && L1 > L0 ) ) dA = 20; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } return A; } double cewma_2_crit_AU_new(double lambda, double L0, double AL, double mu0, double z0, int N, int jmax) { double A, A1, L1; int j, dA; A1 = AL; A = A1; L1 = cewma_2_arl_new(lambda, AL, A1, mu0, z0, mu0, N); /*printf(" A = %.4f,\tL1 = %.6f (L0=%.0f)\n\n", A1, L1, L0);*/ if ( L1 < L0 ) { for (j=0; j<=jmax; j++) { for (dA=1; dA<20; dA++) { A = A1 + dA / pow(-10., (double)j); L1 = cewma_2_arl_new(lambda, AL, A, mu0, z0, mu0, N); /*printf("--A = %.4f,\tL1 = %.6f (L0=%.0f)\n", A, L1, L0);*/ if ( ( fmod((double)j, 2.) < 1. && L1 > L0 ) || ( fmod((double)j, 2.) > 0. && L1 < L0 ) ) dA = 20; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } else { for (j=0; j<=jmax; j++) { for (dA=1; dA<20; dA++) { A = A1 - dA / pow(-10., (double)j); L1 = cewma_2_arl_new(lambda, AL, A, mu0, z0, mu0, N); /*printf("++A = %.4f,\tL1 = %.6f (L0=%.0f)\n", A, L1, L0);*/ if ( ( fmod((double)j, 2.) > 0. && L1 < L0 ) || ( fmod((double)j, 2.) < 1. && L1 > L0 ) ) dA = 20; } A1 = A; } if ( L1 < L0 ) A = A + pow(0.1, (double)jmax); } /*printf("\n");*/ return A; } int cewma_2_crit_unb(double lambda, double L0, double mu0, double z0, int N, int jmax, double *AL, double *AU) { double A1, Lp, Lm, eps=.1, slope, lAL, lAU; int j, dA; lAL = -1.; lAU = -1.; A1 = cewma_2_crit_sym(lambda, L0, mu0, z0, N, jmax); Lp = cewma_2_arl(lambda, A1, A1, mu0, z0, mu0+eps, N); Lm = cewma_2_arl(lambda, A1, A1, mu0, z0, mu0-eps, N); slope = ( Lp - Lm ) / (2*eps); /*printf("\nA1 = %.4f,\tslope = %.6f\n\n", A1, slope);*/ if ( slope > 0 ) { for (j=1; j<=jmax; j++) { for (dA=1; dA<20; dA++) { lAL = A1 - dA / pow(-10., (double)j); lAU = cewma_2_crit_AU(lambda, L0, lAL, mu0, z0, N, jmax); Lp = cewma_2_arl(lambda, lAL, lAU, mu0, z0, mu0+eps, N); Lm = cewma_2_arl(lambda, lAL, lAU, mu0, z0, mu0-eps, N); slope = ( Lp - Lm ) / (2*eps); /*printf("--AL = %.4f,\tAU = %.4f,\tslope = %.6f\n", lAL, lAU, slope);*/ if ( ( fmod((double)j, 2.) > 0. && slope < 0. ) || ( fmod((double)j, 2.) < 1. && slope > 0. ) ) dA = 20; } A1 = lAL; } } else { for (j=1; j<=jmax; j++) { for (dA=1; dA<20; dA++) { lAL = A1 + dA / pow(-10., (double)j); lAU = cewma_2_crit_AU(lambda, L0, lAL, mu0, z0, N, jmax); Lp = cewma_2_arl(lambda, lAL, lAU, mu0, z0, mu0+eps, N); Lm = cewma_2_arl(lambda, lAL, lAU, mu0, z0, mu0-eps, N); slope = ( Lp - Lm ) / (2*eps); /*printf("++AL = %.4f,\tAU = %.4f,\tslope = %.6f\n", lAL, lAU, slope);*/ if ( ( fmod((double)j, 2.) < 1. && slope < 0. ) || ( fmod((double)j, 2.) > 0. && slope > 0. ) ) dA = 20; } A1 = lAL; } } *AL = lAL; *AU = lAU; return 0; } int cewma_2_crit_unb_new(double lambda, double L0, double mu0, double z0, int N, int jmax, double *AL, double *AU) { double A1, symA, Lp, Lm, eps=.01, slope, lAL, lAU, ALmin, AUlarge=10.; int j, dA; symA = cewma_2_crit_sym_new(lambda, L0, mu0, z0, N, jmax); Lp = cewma_2_arl_new(lambda, symA, symA, mu0, z0, mu0+eps, N); Lm = cewma_2_arl_new(lambda, symA, symA, mu0, z0, mu0-eps, N); slope = ( Lp - Lm ) / (2*eps); ALmin = cewma_L_crit_new(lambda, L0, AUlarge, mu0, z0, N, jmax); /*printf("\nsymA = %.4f,\tslope = %.6f,\tALmin = %.4f\n\n", symA, slope, ALmin);*/ lAL = symA; lAU = symA; A1 = symA; if ( slope > 0 ) { for (j=0; j<=jmax; j++) { for (dA=1; dA<30; dA++) { lAL = A1 + dA / pow(-10., (double)j); if ( lAL < ALmin ) { lAL = ALmin + 1./pow(10., (double)j+1); dA = 30; } lAU = cewma_2_crit_AU_new(lambda, L0, lAL, mu0, z0, N, jmax); Lp = cewma_2_arl_new(lambda, lAL, lAU, mu0, z0, mu0+eps, N); Lm = cewma_2_arl_new(lambda, lAL, lAU, mu0, z0, mu0-eps, N); slope = ( Lp - Lm ) / (2*eps); /*printf("--AL = %.4f,\tAU = %.4f,\tslope = %.6f\n", lAL, lAU, slope);*/ if ( ( fmod((double)j, 2.) < 1. && slope < 0. ) || ( fmod((double)j, 2.) > 0. && slope > 0. ) ) dA = 30; } A1 = lAL; } } else { for (j=0; j<=jmax; j++) { /*printf("!!j = %d\n", j);*/ for (dA=1; dA<30; dA++) { lAL = A1 - dA / pow(-10., (double)j); if ( lAL < ALmin ) { lAL = ALmin + 1./pow(10., (double)j+1); dA = 30; } else { if ( lAL > symA ) { /*printf("\nlAL (%.6f) too large\n", lAL);*/ lAL = symA - 1./pow(10., (double)j+1); dA = 30; } } lAU = cewma_2_crit_AU_new(lambda, L0, lAL, mu0, z0, N, jmax); Lp = cewma_2_arl_new(lambda, lAL, lAU, mu0, z0, mu0+eps, N); Lm = cewma_2_arl_new(lambda, lAL, lAU, mu0, z0, mu0-eps, N); slope = ( Lp - Lm ) / (2*eps); /*printf("++AL = %.4f,\tAU = %.4f,\tslope = %.6f\n", lAL, lAU, slope);*/ if ( ( fmod((double)j, 2.) > 0. && slope < 0. ) || ( fmod((double)j, 2.) < 1. && slope > 0. ) ) dA = 30; } A1 = lAL; } } *AL = lAL; *AU = lAU; return 0; } double cewma_2_get_gL(double lambda, double L0, double mu0, double z0, double AL, double AU, double gU, int N) { double gL1, gL2, gL3, L1, L2, L3, dL, dG; gL1 = 1.; L1 = cewma_2_arl_rando_new(lambda, AL, AU, gL1, gU, mu0, z0, mu0, N); gL2 = .9; L2 = cewma_2_arl_rando_new(lambda, AL, AU, gL2, gU, mu0, z0, mu0, N); while ( L1 < L0 ) { gL2 = gL1; L2 = L1; gL1 /= 2.; L1 = cewma_2_arl_rando_new(lambda, AL, AU, gL1, gU, mu0, z0, mu0, N); } do { gL3 = gL1 + (L0 - L1)/(L2 - L1) * (gL2-gL1); L3 = cewma_2_arl_rando_new(lambda, AL, AU, gL3, gU, mu0, z0, mu0, N); dG = gL3 - gL2; dL = L0 - L3; gL1 = gL2; L1 = L2; gL2 = gL3; L2 = L3; } while ( fabs(dL)>.00000000001 && fabs(dG)>.00000000001 ); return gL3; } double cewma_2_get_gU(double lambda, double L0, double mu0, double z0, double AL, double AU, double gL, int N) { double gU1, gU2, gU3, L1, L2, L3, dL, dG; gU1 = 1.; L1 = cewma_2_arl_rando_new(lambda, AL, AU, gL, gU1, mu0, z0, mu0, N); gU2 = .9; L2 = cewma_2_arl_rando_new(lambda, AL, AU, gL, gU2, mu0, z0, mu0, N); while ( L1 < L0 ) { gU2 = gU1; L2 = L1; gU1 /= 2.; L1 = cewma_2_arl_rando_new(lambda, AL, AU, gL, gU1, mu0, z0, mu0, N); } do { gU3 = gU1 + (L0 - L1)/(L2 - L1) * (gU2-gU1); L3 = cewma_2_arl_rando_new(lambda, AL, AU, gL, gU3, mu0, z0, mu0, N); dG = gU3 - gU2; dL = L0 - L3; gU1 = gU2; L1 = L2; gU2 = gU3; L2 = L3; } while ( fabs(dL)>.00000000001 && fabs(dG)>.00000000001 ); return gU3; } int cewma_2_crit_unb_rando_new(double lambda, double L0, double mu0, double z0, int N, int jmax, double *AL, double *AU, double *gL, double *gU) { double A1, symA, Lp, Lm, eps=.01, slope, lAL1, lAL2, lAU1, lAU2, lAL, lAU, g1, g2, g3, u1, u2, u3, s1, s2, s3, miAL, maAL, miAU, maAU, L0act, dg, rdA, ALmin, AUlarge=10.; int j, dA, done=0; symA = cewma_2_crit_sym_new(lambda, L0, mu0, z0, N, jmax); Lp = cewma_2_arl_new(lambda, symA, symA, mu0, z0, mu0+eps, N); Lm = cewma_2_arl_new(lambda, symA, symA, mu0, z0, mu0-eps, N); slope = ( Lp - Lm ) / (2*eps); ALmin = cewma_L_crit_new(lambda, L0, AUlarge, mu0, z0, N, jmax); /*printf("\nsymA = %.4f,\tslope = %.6f,\tALmin = %.4f\n\n", symA, slope, ALmin);*/ lAL1 = symA; lAU1 = symA; A1 = symA; lAL2 = symA; lAU2 = symA; lAU = symA; lAL = symA; u3 = -1.; g3 = -1.; if ( slope > 0 ) { for (j=0; j<=jmax; j++) { for (dA=1; dA<30; dA++) { lAL2 = lAL1; lAU2 = lAU1; lAL1 = A1 + dA / pow(-10., (double)j); if ( lAL1 < ALmin ) { lAL1 = ALmin + 1./pow(10., (double)j+1); dA = 30; } lAU1 = cewma_2_crit_AU_new(lambda, L0, lAL1, mu0, z0, N, jmax); Lp = cewma_2_arl_new(lambda, lAL1, lAU1, mu0, z0, mu0+eps, N); Lm = cewma_2_arl_new(lambda, lAL1, lAU1, mu0, z0, mu0-eps, N); slope = ( Lp - Lm ) / (2*eps); /*printf("--AL = %.4f,\tAU = %.4f,\tslope = %.6f\n", lAL1, lAU1, slope);*/ if ( ( fmod((double)j, 2.) < 1. && slope < 0. ) || ( fmod((double)j, 2.) > 0. && slope > 0. ) ) dA = 30; } A1 = lAL1; } } else { for (j=0; j<=jmax; j++) { /*printf("j = %d\n", j);*/ for (dA=1; dA<30; dA++) { lAL2 = lAL1; lAU2 = lAU1; lAL1 = A1 - dA / pow(-10., (double)j); if ( lAL1 < ALmin ) { /*printf("\nlAL1 too small\n");*/ lAL1 = ALmin + 1./pow(10., (double)j+1); dA = 30; } else { if ( lAL1 > symA ) { /*printf("\nlAL1 (%.6f) too large\n", lAL1);*/ lAL1 = symA - 1./pow(10., (double)j+1); dA = 30; } } lAU1 = cewma_2_crit_AU_new(lambda, L0, lAL1, mu0, z0, N, jmax); Lp = cewma_2_arl_new(lambda, lAL1, lAU1, mu0, z0, mu0+eps, N); Lm = cewma_2_arl_new(lambda, lAL1, lAU1, mu0, z0, mu0-eps, N); slope = ( Lp - Lm ) / (2*eps); /*printf("++AL = %.4f,\tAU = %.4f,\tslope = %.6f\n", lAL1, lAU1, slope);*/ if ( ( fmod((double)j, 2.) > 0. && slope < 0. ) || ( fmod((double)j, 2.) < 1. && slope > 0. ) ) dA = 30; } A1 = lAL1; } } L0act = cewma_2_arl_new(lambda, lAL1, lAU1, mu0, z0, mu0, N); /*printf("\n\nlAL1 = %.8f,\tlAU1 = %.8f,\tslope1 = %.6f,\tL0act = %.3f\n", lAL1, lAU1, slope, L0act); printf("lAL2 = %.8f,\tlAU2 = %.8f\n", lAL2, lAU2);*/ rdA = pow(10.,-(double)jmax); /*printf("rdA = %.8f\n\n", rdA);*/ miAL = lAL1; maAL = lAL2; if ( lAL2 < miAL ) { miAL = lAL2; maAL = lAL1; } miAU = lAU1; maAU = lAU2; if ( lAU2 < miAU ) { miAU = lAU2; maAU = lAU1; } if ( (maAU - miAU)/rdA > 100. ) maAU += 20.*rdA; if ( (maAU - miAU)/rdA > 1000. ) maAU += 200.*rdA; for ( lAL=miAL; lAL<=maAL+rdA/10.; lAL+=rdA ) { /*printf("lAL = %.8f\n", lAL);*/ miAU = cewma_2_crit_AU_new(lambda, L0, lAL, mu0, z0, N, jmax); /*for ( lAU=miAU; lAU<=maAU+rdA/10.; lAU+=rdA ) {*/ for ( lAU=maAU; lAU>=miAU-rdA/10.; lAU-=rdA ) { /*for ( lAU=maAU; lAU>=miAU-rdA; lAU-=rdA ) {*/ /*printf("lAU = %.8f\n", lAU);*/ L0act = cewma_2_arl_rando_new(lambda, lAL, lAU, 0., 0., mu0, z0, mu0, N); if ( L0act < L0 ) { /*printf("L0act too small\n");*/ done = 0; } else { L0act = cewma_2_arl_rando_new(lambda, lAL, lAU, 1., 1., mu0, z0, mu0, N); if ( L0act > L0 ) { /*printf("L0act too large\n");*/ done = 0; } else { g1 = 0.; L0act = cewma_2_arl_rando_new(lambda, lAL, lAU, g1, 1., mu0, z0, mu0, N); if ( L0act < L0 ) { /*printf("\nfull gL interval\n");*/ u1 = cewma_2_get_gU(lambda, L0, mu0, z0, lAL, lAU, g1, N); Lp = cewma_2_arl_rando_new(lambda, lAL, lAU, g1, u1, mu0, z0, mu0+eps, N); Lm = cewma_2_arl_rando_new(lambda, lAL, lAU, g1, u1, mu0, z0, mu0-eps, N); s1 = ( Lp - Lm ) / (2*eps); L0act = cewma_2_arl_rando_new(lambda, lAL, lAU, g1, u1, mu0, z0, mu0, N); /*printf("g1 = %.6f,\tu1 = %.6f,\tL0act = %.3f,\ts1 = %.6f\n\n", g1, u1, L0act, s1);*/ } else { /*printf("\nsearch for min gL\n");*/ u1 = 1.; g1 = cewma_2_get_gL(lambda, L0, mu0, z0, lAL, lAU, u1, N); Lp = cewma_2_arl_rando_new(lambda, lAL, lAU, g1, u1, mu0, z0, mu0+eps, N); Lm = cewma_2_arl_rando_new(lambda, lAL, lAU, g1, u1, mu0, z0, mu0-eps, N); s1 = ( Lp - Lm ) / (2*eps); L0act = cewma_2_arl_rando_new(lambda, lAL, lAU, g1, u1, mu0, z0, mu0, N); /*printf("g1 = %.6f,\tu1 = %.6f,\tL0act = %.3f,\ts1 = %.6f\n\n", g1, u1, L0act, s1);*/ } u2 = 0.; L0act = cewma_2_arl_rando_new(lambda, lAL, lAU, 1., u2, mu0, z0, mu0, N); if ( L0act < L0 ) { /*printf("\nfull gU interval\n");*/ g2 = cewma_2_get_gL(lambda, L0, mu0, z0, lAL, lAU, u2, N); Lp = cewma_2_arl_rando_new(lambda, lAL, lAU, g2, u2, mu0, z0, mu0+eps, N); Lm = cewma_2_arl_rando_new(lambda, lAL, lAU, g2, u2, mu0, z0, mu0-eps, N); s2 = ( Lp - Lm ) / (2*eps); L0act = cewma_2_arl_rando_new(lambda, lAL, lAU, g2, u2, mu0, z0, mu0, N); /*printf("g2 = %.6f,\tu2 = %.6f,\tL0act = %.3f,\ts2 = %.6f\n\n", g2, u2, L0act, s2);*/ } else { /*printf("\nsearch for min gU\n");*/ g2 = 1.; u2 = cewma_2_get_gU(lambda, L0, mu0, z0, lAL, lAU, g2, N); Lp = cewma_2_arl_rando_new(lambda, lAL, lAU, g2, u2, mu0, z0, mu0+eps, N); Lm = cewma_2_arl_rando_new(lambda, lAL, lAU, g2, u2, mu0, z0, mu0-eps, N); s2 = ( Lp - Lm ) / (2*eps); L0act = cewma_2_arl_rando_new(lambda, lAL, lAU, g2, u2, mu0, z0, mu0, N); /*printf("g2 = %.6f,\tu2 = %.6f,\tL0act = %.3f,\ts2 = %.6f\n\n", g2, u2, L0act, s2);*/ } if ( s1*s2 > 0. ) { /*printf("slope does not change sign\n");*/ done = 0; } else { do { g3 = g1 + (0. - s1)/(s2 - s1) * (g2-g1); u3 = cewma_2_get_gU(lambda, L0, mu0, z0, lAL, lAU, g3, N); L0act = cewma_2_arl_rando_new(lambda, lAL, lAU, g3, u3, mu0, z0, mu0, N); Lp = cewma_2_arl_rando_new(lambda, lAL, lAU, g3, u3, mu0, z0, mu0+eps, N); Lm = cewma_2_arl_rando_new(lambda, lAL, lAU, g3, u3, mu0, z0, mu0-eps, N); s3 = ( Lp - Lm ) / (2*eps); /*printf("g3 = %.6f,\tu3 = %.6f,\tL0act = %.3f,\ts3 = %.6f\n", g3, u3, L0act, s3);*/ dg = g3 - g2; g1 = g2; s1 = s2; g2 = g3; s2 = s3; } while ( fabs(s3)>.00000000001 && fabs(dg)>.00000000001 ); done = 1; break; } /* s1*s2 > 0 */ } /* L0act too large */ } /* L0act too small */ } /* lAU=miAU; lAU<=maAU; lAU+=rdA */ if ( done == 1 ) break; } *AL = lAL; *AU = lAU; *gL = g3; *gU = u3; return 0; } /* TEWMA stuff */ double tewma_arl(double lambda, int k, int lk, int uk, double z0, double mu) { double *a, *g, *DM, *DELL, *F2, arl, pij, term; int i, il, j, jl, m, km, l, l0, l1, M, N, kM; N = uk - lk + 1; a = matrix(N, N); g = vector(N); M = (int)qf_pois( 1.-1e-15, mu); DM = vector(M+1); kM = k*M; F2 = matrix(M+1, kM+1); /*for (i=0; i<=M; i++) for (j=0; j<=kM; j++) F2[i*kM+j] = 0.;*/ for (i=0; i<=M; i++) { DM[i] = pdf_pois((double)i, mu); for (j=0; j<=k*i; j++) F2[i*kM+j] = pdf_binom((double)j, k*i, lambda); } DELL = vector(uk+1); for (i=0; i il ) l1 = il; pij = 0.; for (m=0; m<=M; m++) { km = k*m; l0 = jl - km; term = 0.; if ( l0 < 0 ) l0 = 0; if ( l0 <= l1 ) { /*for (l=l0; l<=l1; l++) term += pdf_binom((double)(jl-l), km, lambda) * DELL[l];*/ for (l=l0; l<=l1; l++) term += F2[m*kM+jl-l] * DELL[l]; term *= DM[m]; } pij += term; } /* loop over m */ a[j*N+i] = - pij; } /* loop over j */ ++a[i*N+i]; } /* loop over i */ for (j=0; j il ) l1 = il; pij = 0.; for (m=0; m<=M; m++) { km = k*m; l0 = jl - km; term = 0.; if ( l0 < 0 ) l0 = 0; if ( l0 <= l1 ) { /*for (l=l0; l<=l1; l++) term += pdf_binom((double)(jl-l), km, lambda) * DELL[l];*/ for (l=l0; l<=l1; l++) term += F2[m*kM+jl-l] * DELL[l]; term *= DM[m]; } pij += term; } /* loop over m */ if ( j == 0 ) pij *= 1. - gl; if ( j == N-1 ) pij *= 1. - gu; a[j*N+i] = - pij; } /* loop over j */ ++a[i*N+i]; } /* loop over i */ /* for (i=0; i=0; i--) { b1[i] = 1.; if ( i > 0 ) b2[i-1] += b2[i]; } x[0] = 1./a[N1]; y[0] = 1./a[N1]; phi[0] = b1[0]/a[N1]; psi[0] = b2[0]/a[N1]; for (i=1; i=0; p--) { if ( L1 < A ) { while ( L1 < A ) { hm += pow(10., (double)p); L1 = ccusum_U_arl(mu0, km, hm, m, i0); } } else { while ( L1 >= A ) { hm -= pow(10., (double)p); if ( hm < m && p > 0 ) { p--; hm += pow(10., (double)p+1.) - pow(10., (double)p); } L1 = ccusum_U_arl(mu0, km, hm, m, i0); } } } if ( L1 < A ) hm = hm + 1; return hm; } double ccusum_U_arl_rando(double mu, int km, int hm, int m, double gamma, int i0) { double *a, *b1, *b2, *b3, *x, *y, *z, *phi, *psi, *xi, *rr, *g, *gx, px, al, ga, et, de, be, ka, lambda, arl, nen, zae; int i, j, l, lmax, N, N1; N = hm; N1 = N - 1; a = vector(2*N-1); b1 = vector(N); b2 = vector(N); b3 = vector(N); x = vector(N); y = vector(N); z = vector(N); phi = vector(N); psi = vector(N); xi = vector(N); rr = vector(N); g = vector(N); gx = vector(N); lmax = (int)ceil( (hm + km) / m ) + 1; for (l=0; l<=lmax; l++) { px = pdf_pois((double)l, mu); i = km - l*m; if ( 0 <= N+i-1 && N+i-1 < 2*N-1 ) a[N+i-1] = -px; if ( 0 <= i-1 && i-1 < N ) { b2[i-1] = px; rr[N-i] = px; } if (0 <= N+i && N+i < N ) b3[N+i] = (1.-gamma)*px; } a[N1] += 1.; b2[N-1] = cdf_pois( ceil( (double)(km - hm + 1)/m ) - 1., mu); rr[0] = cdf_pois( (double)(km - hm)/m, mu); for (i=N-1; i>=0; i--) { b1[i] = 1.; if ( i > 0 ) b2[i-1] += b2[i]; } x[0] = 1./a[N1]; y[0] = 1./a[N1]; phi[0] = b1[0]/a[N1]; psi[0] = b2[0]/a[N1]; xi[0] = b3[0]/a[N1]; for (i=1; i=0; i--) { b1[i] = 1.; if ( i > 0 ) b2[i-1] += b2[i]; } x[0] = 1./a[N1]; y[0] = 1./a[N1]; phi[0] = b1[0]/a[N1]; psi[0] = b2[0]/a[N1]; xi[0] = b3[0]/a[N1]; for (i=1; i= A ) { g2 = g1; L2 = L1; g1 /= 2.; lambda = ( 1. + zae ) / ( 1. - g1*(1.-a[N1]) - g1*nen ); L1 = g[i0] + g1 * lambda * gx[i0]; } i = 0; do { i++; g3 = g1 + (A-L1)/(L2-L1) * (g2-g1); lambda = ( 1. + zae ) / ( 1. - g3*(1.-a[N1]) - g3*nen ); L3 = g[i0] + g3 * lambda * gx[i0]; g1 = g2; L1 = L2; g2 = g3; L2 = L3; } while ( fabs(g1-g2)>1e-12 && fabs(L3-A)>1e-10 && i < 100); *hm = ihm; *gamma = 1. - g3; Free(gx); Free(g); Free(rr); Free(xi); Free(psi); Free(phi); Free(z); Free(y); Free(x); Free(b3); Free(b2); Free(b1); Free(a); return 0; } double ccusum_L_arl(double mu, int km, int hm, int m, int i0) { double *a, *b1, *b2, *x, *y, *z, *phi, *psi, *g, px, al, ga, et, de, be, arl; int i, j, l, lmax, N, N1; N = hm + 1; N1 = N - 1; a = vector(2*N-1); b1 = vector(N); b2 = vector(N); x = vector(N); y = vector(N); z = vector(N); phi = vector(N); psi = vector(N); g = vector(N); lmax = (int)ceil( (hm + km) / m ) + 1; for (l=0; l<=lmax; l++) { px = pdf_pois((double)l, mu); i = l*m - km; if ( 0 <= N+i-1 && N+i-1 < 2*N-1 ) a[N+i-1] = -px; if ( 0 <= i-1 && i-1 < N ) b2[i-1] = px; } a[N1] += 1.; b2[N-1] = 1. - cdf_pois( (hm + km)/m, mu); for (i=N-1; i>=0; i--) { b1[i] = 1.; if ( i > 0 ) b2[i-1] += b2[i]; } x[0] = 1./a[N1]; y[0] = 1./a[N1]; phi[0] = b1[0]/a[N1]; psi[0] = b2[0]/a[N1]; for (i=1; i=0; p--) { if ( L1 < A ) { while ( L1 < A ) { hm += pow(10., (double)p); L1 = ccusum_L_arl(mu0, km, hm, m, i0); } } else { while ( L1 >= A ) { hm -= pow(10., (double)p); if ( hm < m && p > 0 ) { p--; hm += pow(10., (double)p+1.) - pow(10., (double)p); } L1 = ccusum_L_arl(mu0, km, hm, m, i0); } } } if ( L1 < A ) hm = hm + 1; return hm; } double ccusum_L_arl_rando(double mu, int km, int hm, int m, double gamma, int i0) { double *a, *b1, *b2, *b3, *x, *y, *z, *phi, *psi, *xi, *rr, *g, *gx, px, al, ga, et, de, be, ka, lambda, arl, nen, zae; int i, j, l, lmax, N, N1; N = hm; N1 = N - 1; a = vector(2*N-1); b1 = vector(N); b2 = vector(N); b3 = vector(N); x = vector(N); y = vector(N); z = vector(N); phi = vector(N); psi = vector(N); xi = vector(N); rr = vector(N); g = vector(N); gx = vector(N); lmax = (int)ceil( (hm + km) / m ) + 1; for (l=0; l<=lmax; l++) { px = pdf_pois((double)l, mu); i = l*m - km; if ( 0 <= N+i-1 && N+i-1 < 2*N-1 ) a[N+i-1] = -px; if ( 0 <= i-1 && i-1 < N ) { b2[i-1] = px; rr[N-i] = px; } if (0 <= N+i && N+i < N ) b3[N+i] = (1.-gamma)*px; } a[N1] += 1.; b2[N-1] = 1. - cdf_pois( (hm + km)/m, mu); rr[0] = 1. - cdf_pois( ceil( (double)(hm + km)/m ) - 1., mu); for (i=N-1; i>=0; i--) { b1[i] = 1.; if ( i > 0 ) b2[i-1] += b2[i]; } x[0] = 1./a[N1]; y[0] = 1./a[N1]; phi[0] = b1[0]/a[N1]; psi[0] = b2[0]/a[N1]; xi[0] = b3[0]/a[N1]; for (i=1; i=0; i--) { b1[i] = 1.; if ( i > 0 ) b2[i-1] += b2[i]; } x[0] = 1./a[N1]; y[0] = 1./a[N1]; phi[0] = b1[0]/a[N1]; psi[0] = b2[0]/a[N1]; xi[0] = b3[0]/a[N1]; for (i=1; i= A ) { g2 = g1; L2 = L1; g1 /= 2.; lambda = ( 1. + zae ) / ( 1. - g1*(1.-a[N1]) - g1*nen ); L1 = g[i0] + g1 * lambda * gx[i0]; } i = 0; do { i++; g3 = g1 + (A-L1)/(L2-L1) * (g2-g1); lambda = ( 1. + zae ) / ( 1. - g3*(1.-a[N1]) - g3*nen ); L3 = g[i0] + g3 * lambda * gx[i0]; g1 = g2; L1 = L2; g2 = g3; L2 = L3; } while ( fabs(g1-g2)>1e-9 && fabs(L3-A)>1e-9 && i < 100); *hm = ihm; *gamma = 1. - g3; Free(gx); Free(g); Free(rr); Free(xi); Free(psi); Free(phi); Free(z); Free(y); Free(x); Free(b3); Free(b2); Free(b1); Free(a); return 0; } double ccusum_2_arl(double mu, int km1, int hm1, int m1, int i01, int km2, int hm2, int m2, int i02) { 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 sufficiently small headstarts !! */ arl1 = ccusum_U_arl(mu, km1, hm1, m1, 0); arl2 = ccusum_U_arl(mu, km1, hm1, m1, i01); arl3 = ccusum_L_arl(mu, km2, hm2, m2, 0); arl4 = ccusum_L_arl(mu, km2, hm2, m2, i02); arl = ( arl2*arl3 + arl1*arl4 - arl1*arl3 ) / ( arl1 + arl3 ); return arl; } double ccusum_2_arl_rando(double mu, int km1, int hm1, int m1, double gamma1, int i01, int km2, int hm2, int m2, double gamma2, int i02) { 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 sufficiently small headstarts !! */ arl1 = ccusum_U_arl_rando(mu, km1, hm1, m1, gamma1, 0); arl2 = ccusum_U_arl_rando(mu, km1, hm1, m1, gamma1, i01); arl3 = ccusum_L_arl_rando(mu, km2, hm2, m2, gamma2, 0); arl4 = ccusum_L_arl_rando(mu, km2, hm2, m2, gamma2, i02); arl = ( arl2*arl3 + arl1*arl4 - arl1*arl3 ) / ( arl1 + arl3 ); return arl; } /* IMR combos, solving Crowder's (1987) integral equation */ double imr_arl_case01(double M, double R, double mu, double sigma, int N, int qm) { double *a, *g, *w, *z, L0, a1, b1, a2, b2, *zch1, *zch2, dN, zi, x0, x1, qi; int i, j, k, NN; /*printf("\ncase 01\n\n");*/ NN = 2*N + 3; dN = (double)N; a1 = -M; b1 = M-R; a2 = R-M; b2 = M; a = matrix(NN, NN); g = vector(NN); zch1 = vector(N); zch2 = vector(N); w = vector(qm); z = vector(qm); for (i=0; i x0 ) x0 = a1; x1 = zi + R; if ( b1 < x1 ) x1 = b1; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j x0 ) x0 = a2; x1 = zi + R; if ( b2 < x1 ) x1 = b2; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j x0 ) x0 = a3; x1 = zi + R; if ( b3 < x1 ) x1 = b3; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j x0 ) x0 = a1; x1 = zi + R; if ( b1 < x1 ) x1 = b1; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j x0 ) x0 = a2; x1 = zi + R; if ( b2 < x1 ) x1 = b2; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j x0 ) x0 = a3; x1 = zi + R; if ( b3 < x1 ) x1 = b3; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j x0 ) x0 = a1; x1 = zi + R; if ( b1 < x1 ) x1 = b1; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j x0 ) x0 = a2; x1 = zi + R; if ( b2 < x1 ) x1 = b2; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j x0 ) x0 = a3; x1 = zi + R; if ( b3 < x1 ) x1 = b3; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j x0 ) x0 = a1; x1 = zi + Ru; if ( b1 < x1 ) x1 = b1; if ( zim < x1 ) x1 = zim; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j x0 ) x0 = zip; x1 = zi + Ru; if ( b1 < x1 ) x1 = b1; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j x0 ) x0 = a2; x1 = zi + Ru; if ( b2 < x1 ) x1 = b2; if ( zim < x1 ) x1 = zim; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j x0 ) x0 = zip; x1 = zi + Ru; if ( b2 < x1 ) x1 = b2; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j x0 ) x0 = a3; x1 = zi + Ru; if ( b3 < x1 ) x1 = b3; if ( zim < x1 ) x1 = zim; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j x0 ) x0 = zip; x1 = zi + Ru; if ( b3 < x1 ) x1 = b3; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j x0 ) x0 = zip; x1 = b3; if ( x1 - x0 > 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j 1e-10 ) { gausslegendre(qm, x0, x1, z, w); for (j=0; j 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 cusumU 0 #define cusumL 1 #define cusum2 2 double scU_iglarl_v1(double refk, double h, double hs, double sigma, int df, int N, int qm); double scU_iglarl_v2(double refk, double h, double hs, double sigma, int df, int N, int qm); double scL_iglarl_v2(double refk, double h, double hs, double sigma, int df, int N, int qm); double sc2_iglarl_v2(double refkl, double refku, double hl, double hu, double hsl, double hsu, double sigma, int df, int N, int qm); void scusum_arl ( int *ctyp, double *k, double *h, double *hs, double *sigma, int *df, double *k2, double *h2, double *hs2, int *r, int *qm, int *version, double *arl) { *arl = -1.; if ( *ctyp==cusumU ) { if ( *version==1 ) *arl = scU_iglarl_v1(*k, *h, *hs, *sigma, *df, *r, *qm); if ( *version==2 ) *arl = scU_iglarl_v2(*k, *h, *hs, *sigma, *df, *r, *qm); } if ( *ctyp==cusumL ) { /*if ( *version==1 ) *arl = scL_iglarl_v1(*k, *h, *hs, *sigma, *df, *r, *qm);*/ if ( *version==2 ) *arl = scL_iglarl_v2(*k, *h, *hs, *sigma, *df, *r, *qm); } if ( *ctyp==cusum2 ) { /*if ( *version==1 ) *arl = sc2_iglarl_v1(*k2, *k, *h2, *h, *hs2, *hs, *sigma, *df, *r, *qm);*/ if ( *version==2 ) *arl = sc2_iglarl_v2(*k2, *k, *h2, *h, *hs2, *hs, *sigma, *df, *r, *qm); } } spc/src/xewma_arl_f.c0000644000176200001440000000173113553640534014270 0ustar liggesusers#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 double xe2_iglarl_f(double l, double c, double mu, int N, double *g, double *w, double *z); double *vector (long n); void xewma_arl_f(int *ctyp, double *l, double *c, double *zr, double *mu, int *ltyp, int *r, double *zeug) { double *ARL, *w, *z, zahl=0.; int i; ARL = vector(*r); w = vector(*r); z = vector(*r); for (i = 0; i < *r; i++) { w[i] = -1.; z[i] = 0.; ARL[i] = 0.; } /* init */ if ( *ctyp==ewma2 && *ltyp==fix ) zahl = xe2_iglarl_f(*l, *c, *mu, *r, ARL, w, z); for (i = 0; i < *r; i++) { zeug[i] = ARL[i]; zeug[i + *r] = w[i]; zeug[i + *r + *r] = z[i]; } Free(z); Free(w); Free(ARL); if ( fabs(zahl) > 1e-9 ) warning("trouble in xewma_arl [package spc]"); } spc/src/cewma_arl_be.c0000644000176200001440000000450213652235650014402 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaL 1 #define ewma2 2 #define classic 0 #define transfer 1 #define cW 2 #define tW 3 double cewma_U_arl(double lambda, double AU, double mu0, double z0, double mu, int N); double cewma_L_arl(double lambda, double AL, double AU, double mu0, double z0, double mu, int N); double cewma_2_arl(double lambda, double AL, double AU, double mu0, double z0, double mu, int N); double cewma_2_arl_rando(double lambda, double AL, double AU, double gammaL, double gammaU, double mu0, double z0, double mu, int N); double cewma_U_arl_new(double lambda, double AU, double mu0, double z0, double mu, int N); double cewma_L_arl_new(double lambda, double AL, double AU, double mu0, double z0, double mu, int N); double cewma_2_arl_new(double lambda, double AL, double AU, double mu0, double z0, double mu, int N); double cewma_2_Warl_new(double lambda, double AL, double AU, double mu0, double z0, double mu, int N, int nmax); double cewma_2_arl_rando_new(double lambda, double AL, double AU, double gammaL, double gammaU, double mu0, double z0, double mu, int N); void cewma_arl_be (int *ctyp, int *mcdesign, int *rando, double *lambda, double *AL, double *AU, double *gL, double *gU, double *mu0, double *z0, double *mu, int *N, double *arl) { int nmax=100000; *arl = -1.; if ( *ctyp==ewmaU && *mcdesign==classic ) *arl = cewma_U_arl(*lambda, *AU, *mu0, *z0, *mu, *N); if ( *ctyp==ewmaU && *mcdesign==transfer ) *arl = cewma_U_arl_new(*lambda, *AU, *mu0, *z0, *mu, *N); if ( *ctyp==ewmaL && *mcdesign==classic ) *arl = cewma_L_arl(*lambda, *AL, *AU, *mu0, *z0, *mu, *N); if ( *ctyp==ewmaL && *mcdesign==transfer ) *arl = cewma_L_arl_new(*lambda, *AL, *AU, *mu0, *z0, *mu, *N); if ( *ctyp==ewma2 && *mcdesign==classic ) { if ( *rando==0 ) *arl = cewma_2_arl(*lambda, *AL, *AU, *mu0, *z0, *mu, *N); if ( *rando==1 ) *arl = cewma_2_arl_rando(*lambda, *AL, *AU, *gL, *gU, *mu0, *z0, *mu, *N); } if ( *ctyp==ewma2 && *mcdesign==transfer ) { if ( *rando==0 ) *arl = cewma_2_arl_new(*lambda, *AL, *AU, *mu0, *z0, *mu, *N); if ( *rando==1 ) *arl = cewma_2_arl_rando_new(*lambda, *AL, *AU, *gL, *gU, *mu0, *z0, *mu, *N); } if ( *ctyp==ewma2 && *mcdesign==tW ) { if ( *rando==0 ) *arl = cewma_2_Warl_new(*lambda, *AL, *AU, *mu0, *z0, *mu, *N, nmax); } } spc/src/xtewma_q.c0000644000176200001440000000214413553640534013630 0ustar liggesusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 /*double xe1_Wq(double l, double c, double p, double zr, double hs, double mu, int N, int nmax); double xe1_Wqm(double l, double c, double p, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax);*/ double xte2_Wq(double l, double c, double p, double hs, int df, double mu, int N, int nmax, int subst); double xte2_Wqm(double l, double c, double p, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, int subst); void xtewma_q(int *ctyp, double *l, double *c, double *p, double *zr, double *hs, int *df, double *mu, int *ltyp, int *r, int *ntyp, int *q, double *tq) { int nmax=1000000; if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xte2_Wq(*l, *c, *p, *hs, *df, *mu, *r, nmax, *ntyp); if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xte2_Wqm(*l, *c, *p, *hs, *df, *q, 0., *mu, *ltyp, *r, nmax, *ntyp); if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xte2_Wqm(*l, *c, *p, *hs, *df, *q, 0., *mu, *ltyp, *r, nmax, *ntyp); } spc/src/xDcusum_arl.c0000644000176200001440000000165413553640534014276 0ustar liggesusers#include #include #include #include #define cusum1 0 #define cusum2 1 #define cusumC 2 #define Gan 0 #define Knoth 1 extern double rho0; double xc1_iglarl_drift(double k, double h, double hs, double delta, int m, int N, int with0); double xc1_iglarl_drift_wo_m(double k, double h, double hs, double delta, int *m, int N, int with0); double xc1_iglarlm_drift(double k, double h, double hs, int q, double delta, int N, int nmax, int with0); void xDcusum_arl ( int *ctyp, double *k, double *h, double *hs, double *delta, int *m, int *r, int *with0, int *mode, int *q, double *arl) { if (*ctyp==cusum1 && *m>0) *arl = xc1_iglarl_drift(*k, *h, *hs, *delta, *m, *r, *with0); if (*ctyp==cusum1 && *m==0 && *mode==Gan) *arl = xc1_iglarl_drift_wo_m(*k, *h, *hs, *delta, m, *r, *with0); if (*ctyp==cusum1 && *m==0 && *mode==Knoth) *arl = xc1_iglarlm_drift(*k, *h, *hs, *q, *delta, *r, 10000, *with0); } spc/src/xewma_sf.c0000644000176200001440000000307713553640534013622 0ustar liggesusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define stat 5 #define test 6 double *vector (long n); double xe1_sf (double l, double c, double zr, double hs, double mu, int N, int nmax, double *p0); double xe1_sfm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0); double xe2_sf (double l, double c, double hs, double mu, int N, int nmax, double *p0); double xe2_sfm(double l, double c, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0); void xewma_sf(int *ctyp, double *l, double *c, double *zr, double *hs, double *mu, int *ltyp, int *r, int *q, int *n, double *sf) { int result=0, i; double *p0; p0 = vector(*n); if ( *ctyp==ewma1 && *ltyp==fix && *q==1 ) result = xe1_sf (*l, *c, *zr, *hs, *mu, *r, *n, p0); if ( *ctyp==ewma1 && *ltyp==fix && *q>1 ) result = xe1_sfm(*l, *c, *zr, *hs, *q, 0., *mu, *ltyp, *r, *n, p0); if ( *ctyp==ewma1 && *ltyp>fix ) result = xe1_sfm(*l, *c, *zr, *hs, *q, 0., *mu, *ltyp, *r, *n, p0); if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) result = xe2_sf (*l, *c, *hs, *mu, *r, *n, p0); if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) result = xe2_sfm(*l, *c, *hs, *q, 0., *mu, *ltyp, *r, *n, p0); if ( *ctyp==ewma2 && *ltyp>fix ) result = xe2_sfm(*l, *c, *hs, *q, 0., *mu, *ltyp, *r, *n, p0); if ( result != 0 ) warning("trouble in xewma_sf [package spc]"); for (i=0; i<*n; i++) sf[i] = p0[i]; } spc/src/xsewma_q.c0000644000176200001440000000166713553640534013640 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewma2 1 double xseU_Wq(double lx, double ls, double cx, double cs, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); double xse2_Wq(double lx, double ls, double cx, double csl, double csu, double p, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); void xsewma_q ( int *ctyp, double *alpha, double *lx, double *cx, double *hsx, int *Nx, double *ls, double *csl, double *csu, double *hss, int *Ns, double *mu, double *sigma, int *df, int *qm, double *tq) { int nmax=100000; *tq = -1.; if ( *ctyp == ewmaU ) *tq = xseU_Wq(*lx, *ls, *cx, *csu, *alpha, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, nmax, *qm); if ( *ctyp == ewma2 ) *tq = xse2_Wq(*lx, *ls, *cx, *csl, *csu, *alpha, *hsx, *hss, *mu, *sigma, *df, *Nx, *Ns, nmax, *qm); } spc/src/phat_pdf.c0000644000176200001440000000103613553640534013567 0ustar liggesusers#include #include #include #include double pdf_phat (double p, double mu, double sigma, int n, double LSL, double USL); double pdf_phat2(double p, double mu, double sigma, int n, double LSL, double USL, int nodes); void phat_pdf (double *x, int *n, double *mu, double *sigma, int *ctyp, double *LSL, double *USL, int *nodes, double *pdf) { *pdf = -1.; if ( *ctyp == 0 ) *pdf = pdf_phat (*x, *mu, *sigma, *n, *LSL, *USL); if ( *ctyp == 1 ) *pdf = pdf_phat2(*x, *mu, *sigma, *n, *LSL, *USL, *nodes); } spc/src/xgrsr_ad.c0000644000176200001440000000063413553640534013616 0ustar liggesusers#include #include #include #include #define grsr1 0 #define grsr2 1 extern double rho0; double xsr1_iglad(double k, double h, double zr, double mu0, double mu1, int N, int MPT); void xgrsr_ad(int *ctyp, double *k, double *h, double *mu0, double *mu1, double *zr, int *r, int *MPT, double *ad) { if (*ctyp==grsr1) *ad = xsr1_iglad(*k, *h, *zr, *mu0, *mu1, *r, *MPT); } spc/src/xDewma_arl.c0000644000176200001440000000362313553640534014071 0ustar liggesusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define sven 5 #define fink 6 #define waldmann 7 #define collocation 8 #define Gan 0 #define Knoth 1 #define Waldm 2 extern double rho0; double xe1_iglarl_drift(double l, double c, double zr, double hs, double delta, int m, int N, int with0); double xe1_iglarl_drift_wo_m(double l, double c, double zr, double hs, double delta, int *m, int N, int with0); double xe1_iglarlm_drift(double l, double c, double zr, double hs, int q, double delta, int N, int nmax, int with0); double xe2_iglarl_drift(double l, double c, double hs, double delta, int m, int N, int with0); double xe2_iglarl_drift_wo_m(double l, double c, double hs, double delta, int *m, int N, int with0); double xe2_iglarlm_drift(double l, double c, double hs, int q, double delta, int N, int nmax, int with0); double xe2_Warl_drift(double l, double c, double hs, double delta, int N, int nmax, int with0); void xDewma_arl ( int *ctyp, double *l, double *c, double *zr, double *hs, double *delta, int *ltyp, int *m, int *r, int *with0, int *mode, int *q, double *arl) { if (*ctyp==ewma1 && *m>0) *arl = xe1_iglarl_drift(*l,*c,*zr,*hs,*delta,*m,*r,*with0); if (*ctyp==ewma1 && *m==0 && *mode==Gan) *arl = xe1_iglarl_drift_wo_m(*l,*c,*zr,*hs,*delta,m,*r,*with0); if (*ctyp==ewma1 && *m==0 && *mode==Knoth) *arl = xe1_iglarlm_drift(*l,*c,*zr,*hs,*q,*delta,*r,10000,*with0); if (*ctyp==ewma2 && *m>0) *arl = xe2_iglarl_drift(*l,*c,*hs,*delta,*m,*r,*with0); if (*ctyp==ewma2 && *m==0 && *mode==Gan) *arl = xe2_iglarl_drift_wo_m(*l,*c,*hs,*delta,m,*r,*with0); if (*ctyp==ewma2 && *m==0 && *mode==Knoth) *arl = xe2_iglarlm_drift(*l,*c,*hs,*q,*delta,*r,10000,*with0); if (*ctyp==ewma2 && *m==0 && *mode==Waldm) *arl = xe2_Warl_drift(*l,*c,*hs,*delta,*r,10000,*with0); } spc/src/xtcusum_arl.c0000644000176200001440000000106313553640534014350 0ustar liggesusers#include #include #include #include #define cusum1 0 #define cusum2 1 double xtc1_iglarl(double k, double h, double hs, int df, double mu, int N, int subst); double xtc2_iglarl(double k, double h, double hs, int df, double mu, int N, int subst); void xtcusum_arl ( int *ctyp, double *k, double *h, double *hs, int *df, double *mu, int *r, int *ntyp, double *arl) { if ( *ctyp == cusum1 ) *arl = xtc1_iglarl(*k, *h, *hs, *df, *mu, *r, *ntyp); if ( *ctyp == cusum2 ) *arl = xtc2_iglarl(*k, *h, *hs, *df, *mu, *r, *ntyp); } spc/src/cewma_crit_be.c0000644000176200001440000000532313660226370014565 0ustar liggesusers#include #include #include #include #define upper 0 #define lower 1 #define two 2 #define sym 0 #define unb 1 #define classic 0 #define transfer 1 double cewma_U_crit(double lambda, double L0, double mu0, double z0, int N, int jmax); double cewma_L_crit(double lambda, double L0, double AU, double mu0, double z0, int N, int jmax); double cewma_2_crit_sym(double lambda, double L0, double mu0, double z0, int N, int jmax); int cewma_2_crit_unb(double lambda, double L0, double mu0, double z0, int N, int jmax, double *AL, double *AU); double cewma_U_crit_new(double lambda, double L0, double mu0, double z0, int N, int jmax); double cewma_L_crit_new(double lambda, double L0, double AU, double mu0, double z0, int N, int jmax); double cewma_2_crit_sym_new(double lambda, double L0, double mu0, double z0, int N, int jmax); int cewma_2_crit_unb_new(double lambda, double L0, double mu0, double z0, int N, int jmax, double *AL, double *AU); int cewma_2_crit_unb_rando_new(double lambda, double L0, double mu0, double z0, int N, int jmax, double *AL, double *AU, double *gL, double *gU); void cewma_crit_be (int *ctyp, int *design, int *mcdesign, int *rando, double *lambda, double *L0, double *AU, double *mu0, double *z0, int *N, int *jmax, double *AA) { int result=0; double lAL, lAU, lgL, lgU; *AA = -1.; if ( *ctyp==upper ) { if ( *mcdesign==classic ) *AA = cewma_U_crit(*lambda, *L0, *mu0, *z0, *N, *jmax); if ( *mcdesign==transfer ) *AA = cewma_U_crit_new(*lambda, *L0, *mu0, *z0, *N, *jmax); } if ( *ctyp==lower ) { if ( *mcdesign==classic ) *AA = cewma_L_crit(*lambda, *L0, *AU, *mu0, *z0, *N, *jmax); if ( *mcdesign==transfer ) *AA = cewma_L_crit_new(*lambda, *L0, *AU, *mu0, *z0, *N, *jmax); } if ( *ctyp==two ) { if ( *design==sym ) { if ( *mcdesign==classic ) *AA = cewma_2_crit_sym(*lambda, *L0, *mu0, *z0, *N, *jmax); if ( *mcdesign==transfer ) *AA = cewma_2_crit_sym_new(*lambda, *L0, *mu0, *z0, *N, *jmax); } if ( *design==unb ) { if ( *rando==0 ) { if ( *mcdesign==classic ) result = cewma_2_crit_unb(*lambda, *L0, *mu0, *z0, *N, *jmax, &lAL, &lAU); if ( *mcdesign==transfer ) result = cewma_2_crit_unb_new(*lambda, *L0, *mu0, *z0, *N, *jmax, &lAL, &lAU); AA[0] = lAL; AA[1] = lAU; } if ( *rando==1 ) { /*if ( *mcdesign==classic ) result = cewma_2_crit_unb(*lambda, *L0, *mu0, *z0, *N, *jmax, &lAL, &lAU);*/ if ( *mcdesign==transfer ) result = cewma_2_crit_unb_rando_new(*lambda, *L0, *mu0, *z0, *N, *jmax, &lAL, &lAU, &lgL, &lgU); AA[0] = lAL; AA[1] = lAU; AA[2] = lgL; AA[3] = lgU; } } } if ( result != 0 ) warning("something went wrong with cewma_2_crit_unb_*"); } spc/src/xcusum_ad.c0000644000176200001440000000141013553640534013766 0ustar liggesusers#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/xsewma_arl.c0000644000176200001440000000162313553640534014146 0ustar liggesusers#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/xewma_sf_prerun.c0000644000176200001440000001212113553640534015203 0ustar liggesusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define stat 5 #define MU 0 #define SIGMA 1 #define BOTH 2 double *vector (long n); double xe2_sf_prerun_MU_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sf_prerun_MU(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double *p0); double xe2_sf_prerun_SIGMA_deluxe(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sf_prerun_SIGMA(double l, double c, double hs, double mu, int pn, int nmax, int qm, double truncate, double *p0); double xe2_sf_prerun_BOTH_deluxe(double l, double c, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double BOUND, double *p0); double xe2_sf_prerun_BOTH(double l, double c, double hs, double mu, int pn, int df, int nmax, int qm1, int qm2, double truncate, double *p0); double xe2_sfm_prerun_MU_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sfm_prerun_MU(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double *p0); double xe2_sfm_prerun_SIGMA_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double BOUND, double *p0); double xe2_sfm_prerun_SIGMA(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate, double *p0); double xe2_sfm_prerun_BOTH_deluxe(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double BOUND, double *p0); double xe2_sfm_prerun_BOTH(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate, double *p0); void xewma_sf_prerun ( int *ctyp, double *l, double *c, double *zr, double *hs, double *mu, int *ltyp, int *q, int *n, int *size, int *df, int *mode, int *qm1, int *qm2, double *truncate, int *tail_approx, double *bound, double *sf) { int i, result=0; double *p0; p0 = vector(*n); if ( *mode == MU ) { if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) { if ( *tail_approx ) result = xe2_sf_prerun_MU_deluxe(*l, *c, *hs, *mu, *size, *n, *qm1, *truncate, *bound, p0); else result = xe2_sf_prerun_MU(*l, *c, *hs, *mu, *size, *n, *qm1, *truncate, p0); } if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) { if ( *tail_approx ) result = xe2_sfm_prerun_MU_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm1, *truncate, *bound, p0); else result = xe2_sfm_prerun_MU(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm1, *truncate, p0); } if ( *ctyp==ewma2 && *ltyp>fix ) { if ( *tail_approx ) result = xe2_sfm_prerun_MU_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm1, *truncate, *bound, p0); else result = xe2_sfm_prerun_MU(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm1, *truncate, p0); } } if ( *mode == SIGMA ) { if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) { if ( *tail_approx ) result = xe2_sf_prerun_SIGMA_deluxe(*l, *c, *hs, *mu, *size, *n, *qm2, *truncate, *bound, p0); else result = xe2_sf_prerun_SIGMA(*l, *c, *hs, *mu, *size, *n, *qm2, *truncate, p0); } if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) { if ( *tail_approx ) result = xe2_sfm_prerun_SIGMA_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm2, *truncate, *bound, p0); else result = xe2_sfm_prerun_SIGMA(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm2, *truncate, p0); } if ( *ctyp==ewma2 && *ltyp>fix ) { if ( *tail_approx ) result = xe2_sfm_prerun_SIGMA_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm2, *truncate, *bound, p0); else result = xe2_sfm_prerun_SIGMA(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, *n, *qm2, *truncate, p0); } } if ( *mode == BOTH ) { if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) { if ( *tail_approx ) result = xe2_sf_prerun_BOTH_deluxe(*l, *c, *hs, *mu, *size, *df, *n, *qm1, *qm2, *truncate, *bound, p0); else result = xe2_sf_prerun_BOTH(*l, *c, *hs, *mu, *size, *df, *n, *qm1, *qm2, *truncate, p0); } if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) { if ( *tail_approx ) result = xe2_sfm_prerun_BOTH_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, *n, *qm1, *qm2, *truncate, *bound, p0); else result = xe2_sfm_prerun_BOTH(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, *n, *qm1, *qm2, *truncate, p0); } if ( *ctyp==ewma2 && *ltyp>fix ) { if ( *tail_approx ) result = xe2_sfm_prerun_BOTH_deluxe(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, *n, *qm1, *qm2, *truncate, *bound, p0); else result = xe2_sfm_prerun_BOTH(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, *n, *qm1, *qm2, *truncate, p0); } } if ( result != 0 ) warning("\nSomething bad happened!\n\n"); for (i=0; i<*n; i++) sf[i] = p0[i]; } spc/src/sewma_q_prerun.c0000644000176200001440000000275713553640534015044 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 double seU_Wq_prerun_SIGMA_deluxe(double l, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); double seUR_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); double seLR_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); double se2_Wq_prerun_SIGMA_deluxe(double l, double cl, double cu, double p, double hs, double sigma, int df1, int df2, int nmax, int qm1, int qm2, double truncate); void sewma_q_prerun ( int *ctyp, double *l, double *cl, double *cu, double *p, double *hs, double *sigma, int *df1, int *r, int *qm1, int *df2, int *qm2, double *truncate, double *tq) { int nmax=100000; if ( *ctyp == ewmaU ) *tq = seU_Wq_prerun_SIGMA_deluxe(*l, *cu, *p, *hs, *sigma, *df1, *df2, nmax, *qm1, *qm2, *truncate); if ( *ctyp == ewma2 ) *tq = se2_Wq_prerun_SIGMA_deluxe(*l, *cl, *cu, *p, *hs, *sigma, *df1, *df2, nmax, *qm1, *qm2, *truncate); if ( *ctyp == ewmaUR ) *tq = seUR_Wq_prerun_SIGMA_deluxe(*l, *cl, *cu, *p, *hs, *sigma, *df1, *df2, nmax, *qm1, *qm2, *truncate); if ( *ctyp == ewmaLR ) *tq = seLR_Wq_prerun_SIGMA_deluxe(*l, *cl, *cu, *p, *hs, *sigma, *df1, *df2, nmax, *qm1, *qm2, *truncate); } spc/src/xshewhart_ar1_arl.c0000644000176200001440000000047413553640534015425 0ustar liggesusers#include #include #include #include double x_shewhart_ar1_arl(double alpha, double cS, double delta, int N1, int N2); void xshewhart_ar1_arl(double *alpha, double *cS, double *delta, int *N1, int *N2, double *arl) { *arl = x_shewhart_ar1_arl(*alpha, *cS, *delta, *N1, *N2); } spc/src/xewma_res_arl.c0000644000176200001440000000054713553640534014640 0ustar liggesusers#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/tshewhart_ar1_arl.c0000644000176200001440000000065013553640534015415 0ustar liggesusers#include #include #include #include double t_shewhart_ar1_arl(double alpha, double cS, double delta, int df, int N1, int N2, int N3, double INF, int subst); void tshewhart_ar1_arl(double *alpha, double *cS, double *delta, int *df, int *N1, int *N2, int *N3, double *INFI, int *subst, double *arl) { *arl = t_shewhart_ar1_arl(*alpha, *cS, *delta, *df, *N1, *N2, *N3, *INFI, *subst); } spc/src/xsewma_res_arl.c0000644000176200001440000000107513553640534015020 0ustar liggesusers#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_crit.c0000644000176200001440000000326213553640534014332 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaUR 1 #define ewma2 2 #define ewmaLR 3 #define fixed 0 #define unbiased 1 int xseU_crit (double lx, double ls, double L0, double *cx, double *cs, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); int xse2lu_crit (double lx, double ls, double L0, double *cx, double csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); int xse2fu_crit (double lx, double ls, double L0, double *cx, double *csl, double csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); int xse2_crit (double lx, double ls, double L0, double *cx, double *csl, double *csu, double hsx, double hss, double mu, double sigma, int df, int Nx, int Ns, int nmax, int qm); void xsewma_crit ( int *ctyp, int *ltyp, double *lx, double *ls, double *L0, double *cu0, double *hsx, double *hss, double *mu, double *sigma, int *df, int *Nx, int *Ns, int *qm, double *c_values) { int result=0; double cx, cl, cu; cx = -1.; cl = 0.; cu = -1.; if (*ctyp==ewmaU) result = xseU_crit(*lx,*ls,*L0,&cx,&cu,*hsx,*hss,*mu,*sigma,*df,*Nx,*Ns,10000,*qm); if (*ctyp==ewma2) { if (*ltyp==fixed) { result = xse2fu_crit(*lx,*ls,*L0,&cx,&cl,*cu0,*hsx,*hss,*mu,*sigma,*df,*Nx,*Ns,10000,*qm); cu = *cu0; } if (*ltyp==unbiased) result = xse2_crit(*lx,*ls,*L0,&cx,&cl,&cu,*hsx,*hss,*mu,*sigma,*df,*Nx,*Ns,10000,*qm); } if ( result != 0 ) warning("trouble with xsewma_crit [package spc]"); c_values[0] = cx; c_values[1] = cl; c_values[2] = cu; } spc/src/lns2ewma_arl.c0000644000176200001440000000131013553640534014363 0ustar liggesusers#include #include #include #include #define ewmaU 0 #define ewmaL 1 #define ewma2 2 double lns2ewmaU_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N); double lns2ewma2_arl_igl(double l, double cl, double cu, double hs, double sigma, int df, int N); void lns2ewma_arl ( int *ctyp, double *l, double *cl, double *cu, double *hs, double *sigma, int *df, int *r, double *arl) { *arl = -1.; if ( *ctyp==ewmaU ) *arl = lns2ewmaU_arl_igl(*l, *cl, *cu, *hs, *sigma, *df, *r); /*if ( *ctyp==ewmaL ) *arl = lns2ewmaL_arl_igl(*l, *cl, *cu, *hs, *sigma, *df, *r);*/ if ( *ctyp==ewma2 ) *arl = lns2ewma2_arl_igl(*l, *cl, *cu, *hs, *sigma, *df, *r); } spc/src/scusum_s_arl.c0000644000176200001440000000117013553640534014500 0ustar liggesusers#include #include #include #include #define cusumU 0 #define cusumL 1 #define cusum2 2 double scs_U_iglarl_v1(double refk, double h, double hs, double cS, double sigma, int df, int N, int qm); void scusum_s_arl ( int *ctyp, double *k, double *h, double *hs, double *cS, double *sigma, int *df, double *k2, double *h2, double *hs2, int *r, int *qm, int *version, double *arl) { *arl = -1.; if ( *ctyp==cusumU ) { if ( *version==1 ) *arl = scs_U_iglarl_v1(*k, *h, *hs, *cS, *sigma, *df, *r, *qm); if ( *version==2 ) *arl = scs_U_iglarl_v1(*k, *h, *hs, *cS, *sigma, *df, *r, *qm); } } spc/src/xewma_q.c0000644000176200001440000000261113553640534013443 0ustar liggesusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define stat 5 #define test 6 double xe1_Wq(double l, double c, double p, double zr, double hs, double mu, int N, int nmax); double xe1_Wqm(double l, double c, double p, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); double xe2_Wq(double l, double c, double p, double hs, double mu, int N, int nmax); double xe2_Wqm(double l, double c, double p, double hs, int q, double mu0, double mu1, int mode, int N, int nmax); void xewma_q(int *ctyp, double *l, double *c, double *p, double *zr, double *hs, double *mu, int *ltyp, int *r, int *q, double *tq) { int nmax=1000000; if ( *ctyp==ewma1 && *ltyp==fix && *q==1 ) *tq = xe1_Wq(*l, *c, *p, *zr, *hs, *mu, *r, nmax); if ( *ctyp==ewma1 && *ltyp==fix && *q>1 ) *tq = xe1_Wqm(*l, *c, *p, *zr, *hs, *q, 0., *mu, *ltyp, *r, nmax); if ( *ctyp==ewma1 && *ltyp>fix ) *tq = xe1_Wqm(*l, *c, *p, *zr, *hs, *q, 0., *mu, *ltyp, *r, nmax); if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) *tq = xe2_Wq(*l, *c, *p, *hs, *mu, *r, nmax); if ( *ctyp==ewma2 && *ltyp==fix && *q>1 ) *tq = xe2_Wqm(*l, *c, *p, *hs, *q, 0., *mu, *ltyp, *r, nmax); if ( *ctyp==ewma2 && *ltyp>fix ) *tq = xe2_Wqm(*l, *c, *p, *hs, *q, 0., *mu, *ltyp, *r, nmax); } spc/src/xtewma_sf.c0000644000176200001440000000230413553640534013776 0ustar liggesusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 double *vector (long n); /* double xe1_sf (double l, double c, double zr, double hs, double mu, int N, int nmax, double *p0); double xe1_sfm(double l, double c, double zr, double hs, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0); */ double xte2_sf(double l, double c, double hs, int df, double mu, int N, int nmax, double *p0, int subst); double xte2_sfm(double l, double c, double hs, int df, int q, double mu0, double mu1, int mode, int N, int nmax, double *p0, int subst); void xtewma_sf(int *ctyp, double *l, double *c, double *zr, double *hs, int *df, double *mu, int *ltyp, int *r, int *ntyp, int *q, int *n, double *sf) { int result=0, i; double *p0; p0 = vector(*n); if ( *ctyp==ewma2 && *ltyp==fix && *q==1 ) { result = xte2_sf(*l, *c, *hs, *df, *mu, *r, *n, p0, *ntyp); } if ( *ctyp==ewma2 && ( ( *ltyp==fix && *q>1 ) || ( *ltyp>fix) ) ) { result = xte2_sfm(*l, *c, *hs, *df, *q, 0., *mu, *ltyp, *r, *n, p0, *ntyp); } if ( result != 0 ) warning("trouble in xtewma_sf [package spc]"); for (i=0; i<*n; i++) sf[i] = p0[i]; } spc/src/xewma_arl_prerun.c0000644000176200001440000000473613553640534015366 0ustar liggesusers#include #include #include #include #define ewma1 0 #define ewma2 1 #define fix 0 #define vacl 1 #define fir 2 #define both 3 #define steiner 4 #define stat 5 #define MU 0 #define SIGMA 1 #define BOTH 2 double xe2_iglarl_prerun_MU(double l, double c, double hs, double mu, int pn, int qm, double truncate); double xe2_iglarl_prerun_SIGMA(double l, double c, double hs, double mu, int pn, int qm, double truncate); double xe2_iglarl_prerun_BOTH(double l, double c, double hs, double mu, int pn, int df, int qm1, int qm2, double truncate); double xe2_arlm_prerun_MU(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate); double xe2_arlm_prerun_SIGMA(double l, double c, double hs, int q, double mu0, double mu1, int pn, int mode, int nmax, int qm, double truncate); double xe2_arlm_prerun_BOTH(double l, double c, double hs, int q, double mu0, double mu1, int pn, int df, int mode, int nmax, int qm1, int qm2, double truncate); void xewma_arl_prerun ( int *ctyp, double *l, double *c, double *zr, double *hs, double *mu, int *ltyp, int *q, int *size, int *df, int *mode, int *qm1, int *qm2, double *truncate, double *arl) { int nmax = 100000; if ( *mode == MU ) { if (*ctyp==ewma2 && *ltyp==fix && *q==1) *arl = xe2_iglarl_prerun_MU(*l, *c, *hs, *mu, *size, *qm1, *truncate); if (*ctyp==ewma2 && *ltyp==fix && *q>1) *arl = xe2_arlm_prerun_MU(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm1, *truncate); if (*ctyp==ewma2 && *ltyp>fix) *arl = xe2_arlm_prerun_MU(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm1, *truncate); } if ( *mode == SIGMA ) { if (*ctyp==ewma2 && *ltyp==fix && *q==1) *arl = xe2_iglarl_prerun_SIGMA(*l, *c, *hs, *mu, *size, *qm2, *truncate); if (*ctyp==ewma2 && *ltyp==fix && *q>1) *arl = xe2_arlm_prerun_SIGMA(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm2, *truncate); if (*ctyp==ewma2 && *ltyp>fix) *arl = xe2_arlm_prerun_SIGMA(*l, *c, *hs, *q, 0., *mu, *size, *ltyp, nmax, *qm2, *truncate); } if ( *mode == BOTH ) { if (*ctyp==ewma2 && *ltyp==fix && *q==1) *arl = xe2_iglarl_prerun_BOTH(*l, *c, *hs, *mu, *size, *df, *qm1, *qm2, *truncate); if (*ctyp==ewma2 && *ltyp==fix && *q>1) *arl = xe2_arlm_prerun_BOTH(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, nmax, *qm1, *qm2, *truncate); if (*ctyp==ewma2 && *ltyp>fix) *arl = xe2_arlm_prerun_BOTH(*l, *c, *hs, *q, 0., *mu, *size, *df, *ltyp, nmax, *qm1, *qm2, *truncate); } } spc/src/ewma_phat_crit_coll.c0000644000176200001440000000134513553640534016004 0ustar liggesusers#include #include #include #include double ewma_phat_crit(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm); double ewma_phat_crit2(double lambda, double L0, double mu, double sigma, int n, double z0, double LSL, double USL, int N, int qm, int M); void ewma_phat_crit_coll (double *lambda, double *L0, double *mu, double *sigma, int *n, double *z0, int *ctyp, double *LSL, double *USL, int *N, int *qm, double *ucl) { int M=4; *ucl = -1.; if ( *ctyp == 0 ) *ucl = ewma_phat_crit(*lambda, *L0, *mu, *sigma, *n, *z0, *LSL, *USL, *N, *qm); if ( *ctyp == 1 ) *ucl = ewma_phat_crit2(*lambda, *L0, *mu, *sigma, *n, *z0, *LSL, *USL, *N, *qm, M); } spc/src/phat_qf.c0000644000176200001440000000102513553640534013422 0ustar liggesusers#include #include #include #include double qf_phat(double p0, double mu, double sigma, int n, double LSL, double USL); double qf_phat2(double p0, double mu, double sigma, int n, double LSL, double USL, int nodes); void phat_qf (double *x, int *n, double *mu, double *sigma, int *ctyp, double *LSL, double *USL, int *nodes, double *qf) { *qf = -1.; if ( *ctyp == 0 ) *qf = qf_phat(*x, *mu, *sigma, *n, *LSL, *USL); if ( *ctyp == 1 ) *qf = qf_phat2(*x, *mu, *sigma, *n, *LSL, *USL, *nodes); } spc/R/0000755000176200001440000000000014304107611011235 5ustar liggesusersspc/R/xcusum.q.R0000644000176200001440000000140713553640534013160 0ustar liggesusers# Computation of CUSUM quantiles (mean monitoring) xcusum.q <- function(k, h, mu, alpha, hs=0, sided="one", r=40) { if ( k < 0 ) stop("k has to be non-negative") if ( h <= 0 ) stop("h has to be positive") if ( hs<0 | (sided=="two" & hs>h/2+k) | (sided=="one" & hs>h/2+k) ) stop("wrong headstart") if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid cusum type") if ( r < 4 ) stop("r (dimension of Markov chain) is too small") quant <- .C("xcusum_q", as.integer(ctyp), as.double(k),as.double(h), as.double(alpha), as.double(hs), as.double(mu), as.integer(r), ans=double(length=1),PACKAGE="spc")$ans names(quant) <- "q" quant } spc/R/sewma.q.prerun.R0000644000176200001440000000274513553640534014270 0ustar liggesusers# Computation of EWMA quantiles (variance monitoring) with pre-run uncertainty sewma.q.prerun <- function(l, cl, cu, sigma, df1, df2, alpha, hs=1, sided="upper", r=40, qm=30, qm.sigma=30, truncate=1e-10) { if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1") if ( cu<=0 ) stop("cu has to be positive") if ( cl<0 ) stop("cl has to be non-negative") if ( sided!="upper" & cl<1e-6 ) stop("cl is too small") if ( sigma<=0 ) stop("sigma must be positive") if ( df1<1 ) stop("df1 must be larger than or equal to 1") if ( df2<1 ) stop("df2 must be larger than or equal to 1") if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)") if ( hscu ) stop("wrong headstart hs") ctyp <- pmatch(sided, c("upper","Rupper","two","Rlower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") if ( r<10 ) stop("r is too small") if ( qm<5 ) stop("qm is too small") if ( qm.sigma<4 ) stop("qm.sigma is too small") if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") quant <- .C("sewma_q_prerun", as.integer(ctyp), as.double(l), as.double(cl), as.double(cu), as.double(alpha), as.double(hs), as.double(sigma), as.integer(df1), as.integer(r), as.integer(qm), as.integer(df2), as.integer(qm.sigma), as.double(truncate), ans=double(length=1),PACKAGE="spc")$ans names(quant) <- "q" quant }spc/R/xtcusum.arl.R0000644000176200001440000000165313553640534013665 0ustar liggesusers# Computation of CUSUM ARLs (mean monitoring, t distributed data) xtcusum.arl <- function(k, h, df, mu, hs=0, sided="one", mode="tan", r=30) { if ( k < 0 ) stop("k has to be non-negative") if ( h <= 0 ) stop("h has to be positive") if ( df < 1 ) stop("df must be greater or equal to 1") if ( hs < 0 | ( sided=="two" & hs>h/2+k ) | ( sided=="one" & hs>h ) ) stop("wrong headstart") ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan")) if ( is.na(ntyp) ) stop("substitution type not provided (yet)") if ( r < 4 ) stop("r is too small") ctyp <- pmatch(sided, c("one", "two")) - 1 if (is.na(ctyp)) stop("invalid cusum type") arl <- .C("xtcusum_arl", as.integer(ctyp), as.double(k), as.double(h), as.double(hs), as.integer(df), double(mu), as.integer(r), as.integer(ntyp), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- NULL return (arl) }spc/R/x.res.ewma.arl.R0000644000176200001440000000137613553640534014146 0ustar liggesusers# 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/xs.res.ewma.pms.R0000644000176200001440000000265013553640534014346 0ustar liggesusers# 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/sewma.q.crit.R0000644000176200001440000000353213553640534013711 0ustar liggesusers# Computation of EWMA critical values for given QRL (variance monitoring) sewma.q.crit <- function(l, L0, alpha, df, sigma0=1, cl=NULL, cu=NULL, hs=1, sided="upper", mode="fixed", ur=4, r=40, qm=30, c.error=1e-12, a.error=1e-9) { cu0 <- cl0 <- 0 if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( L0<1 ) stop("L0 is too small") if ( alpha<=0 | alpha>=1 ) stop("quantile level alpha must be in (0,1)") if ( df<1 ) stop("df must be positive") if ( sigma0<=0 ) stop("sigma0 must be positive") if ( sided=="Rupper" ) { if ( is.null(cl) ) stop("set cl") if ( cl<=0 ) stop("cl must be positive") cl0 <- cl if ( hs1) stop("lx has to be between 0 and 1") if (ls<=0 || ls>1) stop("ls has to be between 0 and 1") if (L0<1) stop("L0 is too small") if ( alpha<=0 | alpha>=1 ) stop("quantile level alpha must be in (0,1)") if ( df<1 ) stop("df must be positive") if ( sigma0<=0 ) stop("sigma0 must be positive") if ( mode=="fixed" & sided=="two" ) { if ( is.null(csu) ) stop("set csu") if ( csucsu ) stop("hs must be smaller than csu") cu0 <- csu } else { cu0 <- 0 } ctyp <- pmatch(sided, c("upper","two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- pmatch(mode, c("fixed","unbiased")) - 1 if ( is.na(ltyp) ) stop("invalid limits type") if ( Nx<5 ) stop("Nx is too small") if ( Ns<10 ) stop("Ns is too small") if ( qm<10 ) stop("qm is too small") c <- .C("xsewma_q_crit", as.integer(ctyp), as.integer(ltyp), as.double(lx), as.double(ls), as.double(L0), as.double(alpha), as.double(cu0), as.double(hsx), as.double(hss), as.double(mu0), as.double(sigma0), as.integer(df), as.integer(Nx), as.integer(Ns), as.integer(qm), as.double(c.error), as.double(a.error), ans=double(length=3),PACKAGE="spc")$ans names(c) <- c("cx", "csl","csu") return (c) } spc/R/pois.cusum.arl.R0000644000176200001440000000263113553640534014257 0ustar liggesusers# Computation of Poisson CUSUM ARLs pois.cusum.arl <- function(mu, km, hm, m, i0=0, sided="upper", rando=FALSE, gamma=0, km2=0, hm2=0, m2=0, i02=0, gamma2=0) { if ( mu < 0 ) stop("mu has to be positive") if ( km < 1 ) stop("km has to be >= 1") if ( hm < 1 ) stop("hm has to be >= 1") if ( m < 1 ) stop("m has to be >= 1") if ( !(i0 %in% 0:hm) ) stop("head start i0 has to be an integer in 0, 1, ..., hm") ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1 if ( is.na(ctyp) ) stop("invalid cusum type") if ( rando ) { if ( gamma < 0 | gamma > 1) stop("gamma has to be a probability value (0<=.<=1)") } if ( ctyp==2 ) { if ( km2 < 1 ) stop("km2 has to be >= 1") if ( hm2 < 1 ) stop("hm2 has to be >= 1") if ( m2 < 1 ) stop("m2 has to be >= 1") if ( !(i02 %in% 0:hm) ) stop("head start i02 has to be an integer in 0, 1, ..., hm") if ( rando ) { if ( gamma2 < 0 | gamma2 > 1) stop("gamma2 has to be a probability value (0<=.<=1)") } } arl <- .C("ccusum_arl_be", as.integer(ctyp), as.integer(rando), as.double(mu), as.integer(km), as.integer(hm), as.integer(m), as.integer(i0), as.double(gamma), as.integer(km2), as.integer(hm2), as.integer(m2), as.integer(i02), as.double(gamma2), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- "arl" arl } spc/R/mewma.arl.f.R0000644000176200001440000002207213553640534013505 0ustar liggesusers# Computation of MEWMA ARLs (multivariate mean monitoring), returns function mewma.arl.f <- function(l, cE, p, delta=0, r=20, ntype=NULL, qm0=20, qm1=qm0) { if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( cE<=0 ) stop("threshold c has to be positive") if ( p<1 ) stop("wrong dimension parameter") if ( delta<0 ) stop("wrong magnitude value") if ( r<4 ) stop("resolution too small") if ( qm0<5 ) stop("more quadrature nodes needed") if ( qm1<5 ) stop("more quadrature nodes needed") if ( is.null(ntype) ) { if ( delta <1e-10 ) { ntype <- "gl2" } else { #if ( p %in% c(2,4) ) { if ( p==2 ) { ntype <- "gl3" } else { ntype <- "gl5" } } } # collocation basis of Chebshev polynomials Tn <- Vectorize(function(z, n) { if ( n==0 ) result <- 1 if ( n==1 ) result <- z if ( n==2 ) result <- 2*z^2 - 1 if ( n==3 ) result <- 4*z^3 - 3*z if ( n==4 ) result <- 8*z^4 - 8*z^2 + 1 if ( n==5 ) result <- 16*z^5 - 20*z^3 + 5*z if ( n>5 ) result <- cos( n*acos(z) ) result }) qtyp <- pmatch(tolower(ntype), c("gl", "co", "ra", "cc", "mc", "sr", "co2", "gl2", "gl3", "gl4", "gl5", "co3", "co4", "ngl1", "ngl2", "ngl3", "ngl4", "ngl5")) - 1 if ( is.na(qtyp) ) stop("invalid type of numerical algorithm") if ( abs(delta) < 1e-10 ) { # in-control LENGTH <- 3*r zeug <- .C("mewma_arl_f", as.double(l), as.double(cE), as.integer(p), as.double(delta), as.integer(r), as.integer(qtyp), as.integer(qm0), as.integer(qm1), ans=double(length=LENGTH), PACKAGE="spc")$ans g <- zeug[1:r] w <- zeug[1:r + r] z <- zeug[1:r + 2*r] # helper functions cE <- cE * l/(2-l) l2 <- ( (1-l)/l )^2 fchi <- function(a, u) dchisq( u/l^2, p, ncp=l2*a ) / l^2 FCHI <- function(a, u) pchisq( u/l^2, p, ncp=l2*a ) if ( qtyp %in% c(0,2,5) ) arl <- Vectorize(function(a) 1 + sum( w * fchi(a, z) * g ), "a") # ordinary GL or Radau or Simpson rule Nystroem if ( qtyp==7 ) arl <- Vectorize(function(a) 1 + sum( w * fchi(a, z^2) * g * 2*z ), "a") # GL Nystroem with ()^2 substitution if ( qtyp==1 ) arl <- Vectorize(function(a) sum( Tn( (2*a-cE)/cE, 0:(r-1) ) * g ), "a") # collocation if ( qtyp==3 ) arl <- Vectorize(function(a) 1 + sum( w * fchi(a, z^2) * g ) * cE/2 , "a") # Clenshaw-Curtis if ( qtyp==4 ) arl <- Vectorize(function(a) 1 + sum( ( FCHI(a, z^2) - FCHI(a, c(0, z[-length(z)]^2)) ) * g), "a") # Markov chain (Runger/Prabhu) } else { # out-of-control if ( qtyp==4 ) { cE_ <- sqrt( cE * l/(2-l) ) w <- 2*cE_/( 2*r + 1 ) ii <- function(ix, iy) (ix-r)^2 + iy^2 < cE_^2/w^2 CIRC <- as.vector( t(outer( 0:(2*r), 0:r, ii)) ) dQ <- sum(CIRC) LENGTH <- dQ } else { r2 <- r^2 LENGTH <- r2 + 4*r } zeug <- .C("mewma_arl_f", as.double(l), as.double(cE), as.integer(p), as.double(delta), as.integer(r), as.integer(qtyp), as.integer(qm0), as.integer(qm1), ans=double(length=LENGTH), PACKAGE="spc")$ans if ( qtyp!=4 ) { g <- zeug[1:r2] w0 <- zeug[1:r + r2] z0 <- zeug[1:r + r2 + r] w1 <- zeug[1:r + r2 + 2*r] z1 <- zeug[1:r + r2 + 3*r] } else { g <- zeug[1:dQ] } # helpers l2 <- ( (1-l)/l )^2 h <- cE * l/(2-l) rdc <- l * sqrt( delta/h ) sig <- l / sqrt( h ) lsd <- l * sqrt( delta ) if ( qtyp %in% c(0, 2, 3, 5) ) arl <- Vectorize(function(a, b) { # ordinary GL or Radau or CC or Simpson rule Nystroem if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta ) b_ <- b / sqrt( delta * h ) m <- rdc + (1-l)*b_ eta <- l2 * h * (1-b_^2) * a_ if ( eta < 1e-10 ) eta <- 0 result <- 1 for ( i in 1:r ) { korr <- h * (1-z1[i]^2) / l^2 outer <- korr * w1[i] * dnorm( z1[i], mean=m, sd=sig) inner <- sum( w0 * dchisq( korr*z0, p-1, eta) * g[ (i-1)*r + 1:r ] ) result <- result + inner * outer } result }) if ( qtyp==7 ) arl <- Vectorize(function(a, b) { # GL Nystroem with ()^2 substitution if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta ) b_ <- b / sqrt( delta * h ) m <- rdc + (1-l)*b_ eta <- l2 * h * (1-b_^2) * a_ if ( eta < 1e-10 ) eta <- 0 result <- 1 for ( i in 1:r ) { korr <- h * (1-z1[i]^2) / l^2 outer <- korr * w1[i] * dnorm( z1[i], mean=m, sd=sig) inner <- sum( w0 * dchisq( korr*z0^2, p-1, eta) * 2*z0 * g[ (i-1)*r + 1:r ] ) result <- result + inner * outer } result }) if ( qtyp==8 ) arl <- Vectorize(function(a, b) { # GL Nystroem with ()^2 plus sin() substitution if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta ) b_ <- b / sqrt( delta * h ) m <- rdc + (1-l)*b_ eta <- l2 * h * (1-b_^2) * a_ if ( eta < 1e-10 ) eta <- 0 result <- 1 for ( i in 1:r ) { korr <- h * ( 1 - sin(z1[i])^2 ) / l^2 outer <- korr * w1[i] * dnorm( sin(z1[i]), mean=m, sd=sig) * cos(z1[i]) inner <- sum( w0 * dchisq( korr*z0^2, p-1, eta) * 2*z0 * g[ (i-1)*r + 1:r ] ) result <- result + inner * outer } result }) if ( qtyp==9 ) arl <- Vectorize(function(a, b) { # GL Nystroem with ()^2 plus tan() substitution if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta ) b_ <- b / sqrt( delta * h ) m <- rdc + (1-l)*b_ eta <- l2 * h * (1-b_^2) * a_ if ( eta < 1e-10 ) eta <- 0 result <- 1 for ( i in 1:r ) { korr <- h * ( 1 - tan(z1[i])^2 ) / l^2 outer <- korr * w1[i] * dnorm( tan(z1[i]), mean=m, sd=sig) / cos(z1[i])^2 inner <- sum( w0 * dchisq( korr*z0^2, p-1, eta) * 2*z0 * g[ (i-1)*r + 1:r ] ) result <- result + inner * outer } result }) if ( qtyp==10 ) arl <- Vectorize(function(a, b) { # GL Nystroem with ()^2 plus sinh() substitution norm <- sinh(1) if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta ) b_ <- b / sqrt( delta * h ) m <- rdc + (1-l)*b_ eta <- l2 * h * (1-b_^2) * a_ if ( eta < 1e-10 ) eta <- 0 result <- 1 for ( i in 1:r ) { korr <- h * ( 1 - (sinh(z1[i])/norm)^2 ) / l^2 outer <- korr * w1[i] * dnorm( sinh(z1[i])/norm, mean=m, sd=sig) * cosh(z1[i])/norm inner <- sum( w0 * dchisq( korr*z0^2, p-1, eta) * 2*z0 * g[ (i-1)*r + 1:r ] ) result <- result + inner * outer } result }) if ( qtyp %in% c(1, 6, 11, 12) ) arl <- Vectorize(function(a, b) { # collocation if ( abs(h-a) < 1e-10 ) a_ <- 1 else a_ <- ( a - b^2/delta ) / ( h - b^2/delta ) b_ <- b / sqrt( delta * h ) result <- 0 for ( i in 1:r ) { outer <- Tn( 2*a_-1, i-1 ) inner <- sum( Tn( b_, 0:(r-1)) * g[ (i-1)*r + 1:r ] ) result <- result + inner * outer } result }) if ( qtyp==4 ) arl <- Vectorize(function(a, b) { # Markov chain (Runger/Prabhu) #a <- sqrt(a) cE_ <- sqrt( cE * l/(2-l) ) w <- 2*cE_/( 2*r + 1 ) wl <- w^2 / l^2 ii <- function(ix, iy) (ix-r)^2 + iy^2 < cE_^2/w^2 Vf <- function(iy,jy) pchisq( (jy+.5)^2*wl, p-1, ncp=(iy*w)^2*l2) - as.numeric(jy>0)*pchisq( (jy-.5)^2*wl, p-1, ncp=(iy*w)^2*l2) Hf <- function(ix,jx) pnorm( (-cE_+(jx+1)*w-(1-l)*(-cE_+(ix+.5)*w) )/l, mean=delta) - pnorm( (-cE_+jx*w-(1-l)*(-cE_+(ix+.5)*w) )/l, mean=delta) CIRC <- as.vector( t(outer( 0:(2*r), 0:r, ii)) ) Vv <- Vf( a/w, 0:r ) Hv <- Hf( (b+cE_)/w-.5, 0:(2*r) ) dQ <- sum(CIRC) Qv <- as.vector( Vv %o% Hv ) Qv_ <- Qv[ CIRC ] result <- 1 + sum( Qv_ * g ) }) if ( qtyp %in% c(13, 14, 15, 16, 17) ) arl <- Vectorize(function(a, b) { # new GL designs gam <- 0 #if ( a > 0 ) gam <- b / sqrt( a * delta ) if ( a > 0 ) gam <- b / sqrt( a ) mij <- lsd + (1 - l ) * sqrt(a) * gam ncpij <- l2 * a * ( 1 - gam^2 ) norm <- sinh(1) result <- 1 for ( i in 1:r ) { if ( qtyp == 13 ) korr <- w0[i] * sqrt( z0[i] ) / l^2 if ( qtyp > 13 ) korr <- 2 * w0[i] * z0[i]^2 / l^2 wl <- z1 korr2 <- rep(1, r) if ( qtyp == 15 ) { wl <- sin( z1 ); korr2 <- cos( z1 ) } if ( qtyp == 16 ) { wl <- tan( z1 ); korr2 <- 1 / ( cos( z1 )^2 ) } if ( qtyp == 17 ) { wl <- sinh( z1 ) / norm; korr2 <- cosh( z1 ) / norm } if ( qtyp == 13 ) term <- korr * sum( w1 * dnorm( (sqrt(z0[i])*wl - mij)/l ) / l * dchisq( z0[i]*( 1 - wl^2 ) / l^2, p-1, ncpij ) * g[ (i-1)*r + 1:r ] * korr2 ) if ( qtyp > 13 ) term <- korr * sum( w1 * dnorm( (z0[i]*wl - mij)/l ) / l * dchisq( z0[i]^2*( 1 - wl^2 ) / l^2, p-1, ncpij ) * g[ (i-1)*r + 1:r ] * korr2 ) result <- result + term } result }) } arl } spc/R/xDgrsr.arl.R0000644000176200001440000000216413553640534013424 0ustar liggesusers# 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/xDshewhartrunsrules.arl.R0000644000176200001440000000103413553640534016252 0ustar liggesusers xDshewhartrunsrules.arl <- function(delta, c=1, m=NULL, type="12") { eps <- 1e-6 if ( is.null(m) ) { m <- 4 arl1 <- xDshewhartrunsrulesFixedm.arl(delta, c=c, m=m, type=type) arl2 <- arl1 + 2*eps while ( abs(arl2-arl1)>eps & m<1e4 ) { m <- round(1.5 * m) arl1 <- xDshewhartrunsrulesFixedm.arl(delta, c=c, m=m, type=type) arl2 <- xDshewhartrunsrulesFixedm.arl(delta, c=c, m=m+1, type=type) } arl <- arl1 } else { arl <- xDshewhartrunsrulesFixedm.arl(delta, c=c, m=m, type=type) } arl }spc/R/xewma.crit.prerun.R0000644000176200001440000000506613553640534014775 0ustar liggesusersxewma.crit.prerun <- function(l, L0, mu, zr=0, hs=0, sided="two", limits="fix", size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, c.error=1e-12, L.error=1e-9, OUTPUT=FALSE) { if ( OUTPUT ) cat("\nc\t\tL\n") c2 <- xewma.crit(l, L0, mu0=mu, zr=zr, hs=hs, sided=sided, limits=limits) L2 <- xewma.arl.prerun(l, c2, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate) if ( OUTPUT ) cat(paste(c2,"\t",L2,"\n")) if ( L2 < L0 ) { while ( L2 < L0 ) { L1 <- L2 c2 <- c2 + .5 L2 <- xewma.arl.prerun(l, c2, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate) if ( OUTPUT ) cat(paste(c2,"\t",L2,"\n")) } c1 <- c2 - .5 } else { while ( L2 >= L0 ) { L1 <- L2 c2 <- c2 - .5 L2 <- xewma.arl.prerun(l, c2, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate) if ( OUTPUT ) cat(paste(c2,"\t",L2,"\n")) } c1 <- c2 + .5 } if ( size < 51 ) { if ( qm.mu < 70 ) qm.mu <- 70 if ( qm.mu < 70 ) qm.mu <- 70 if ( size < 31 ) { if ( qm.mu < 90 ) qm.mu <- 90 if ( qm.mu < 90 ) qm.mu <- 90 } if ( L2 < L0 ) { while ( L2 < L0 ) { L1 <- L2 c2 <- c2 + .1 L2 <- xewma.arl.prerun(l, c2, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate) if ( OUTPUT ) cat(paste(c2,"\t",L2,"\n")) } c1 <- c2 - .1 } else { while ( L2 >= L0 ) { L1 <- L2 c2 <- c2 - .1 L2 <- xewma.arl.prerun(l, c2, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate) if ( OUTPUT ) cat(paste(c2,"\t",L2,"\n")) } c1 <- c2 + .1 } } L.error_ <- 1; c.error_ <- 1 while ( L.error_ > L.error & c.error_ > c.error ) { c3 <- c1 + (L0 - L1)/(L2 - L1)*(c2 - c1) L3 <- xewma.arl.prerun(l, c3, mu, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate) if ( OUTPUT ) cat(paste(c3,"\t",L3,"\n")) c1 <- c2; c2 <- c3 L1 <- L2; L2 <- L3 L.error_ <- abs(L2 - L0); c.error_ <- abs(c2 - c1) } names(c3) <- "c" c3 } spc/R/xtewma.q.crit.R0000644000176200001440000000204713553640534014102 0ustar liggesusersxtewma.q.crit <- function(l, L0, df, mu, alpha, zr=0, hs=0, sided="two", limits="fix", mode="tan", r=40, c.error=1e-12, a.error=1e-9, OUTPUT=FALSE) { c2 <- 0 p2 <- 1 if ( OUTPUT ) cat("\nc\t\tp\n") while ( p2 > alpha ) { p1 <- p2 c2 <- c2 + .5 p2 <- 1 - xtewma.sf(l, c2, df, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } while ( p2 <= alpha & c2 > .02 ) { p1 <- p2 c2 <- c2 - .02 p2 <- 1 - xtewma.sf(l, c2, df, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } c1 <- c2 + .02 a.error_ <- 1; c.error_ <- 1 while ( a.error_ > a.error & c.error_ > c.error ) { c3 <- c1 + (alpha - p1)/(p2 - p1)*(c2 - c1) p3 <- 1 - xtewma.sf(l, c3, df, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0] if ( OUTPUT ) cat(paste(c3,"\t",p3,"\n")) c1 <- c2; c2 <- c3 p1 <- p2; p2 <- p3 a.error_ <- abs(p2 - alpha); c.error_ <- abs(c2 - c1) } names(c3) <- "c" c3 } spc/R/imr.MandRu.R0000644000176200001440000000140514017233562013342 0ustar liggesusersimr.MandRu <- function(L0, N=30, qm=30) { Xarl <- function(M) 1/(2*pnorm(-M)) MRarl <- function(Ru, N=20, qm=30) ifelse(Ru<100, imr.arl(10, Ru, 0, 1, N=N, qm=qm), Inf) M0 <- qnorm(1-1/(2*L0)) M1 <- M0 + .1 delta <- Vectorize(function(x) { LM <- Xarl(x) Ru <- imr.Ru_Mgiven(x, L0, N=N, qm=qm) LR <- MRarl(Ru, N=N, qm=qm) LM - LR }) D1 <- delta(M1) if ( D1 > 0 ) { while ( D1 > 0 ) { M2 <- M1 D2 <- D1 M1 <- mean(c(M0,M1)) D1 <- delta(M1) } M <- uniroot(delta, c(M1, M2), tol=1e-9)$root } else { while ( D1 < 0 ) { M2 <- M1 D2 <- D1 M1 <- M1 + .1 D1 <- delta(M1) } M <- uniroot(delta, c(M2, M1), tol=1e-9)$root } Ru <- imr.Ru_Mgiven(M, L0, N=N, qm=qm) c(M, Ru) } spc/R/xsewma.q.R0000644000176200001440000000260313553640534013137 0ustar liggesusers# Computation of EWMA RL quantiles (simultaneous mean & variance monitoring) xsewma.q <- function(lx, cx, ls, csu, df, alpha, mu, sigma, hsx=0, Nx=40, csl=0, hss=1, Ns=40, sided="upper", qm=30) { if ( lx<=0 | lx>1 ) stop("lx has to be between 0 and 1") if ( ls<=0 | ls>1 ) stop("ls has to be between 0 and 1") if ( cx<=0 ) stop("cx has to be positive") if ( csu<=0 ) stop("csu has to be positive") if ( df<1 ) stop("df must be larger than or equal to 1") if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)") if ( sigma<=0 ) stop("sigma must be positive") if ( abs(hsx)>cx ) stop("wrong headstart hsx") if ( Nx<5 ) stop("Nx is too small") if ( csl<0 ) stop("clu has to be non-negative") if ( hsscsu ) stop("wrong headstart hss") if ( Ns<10 ) stop("Ns is too small") ctyp <- pmatch(sided, c("upper","two")) - 1 if (is.na(ctyp)) stop("invalid ewma type") if ( qm<5 ) stop("qm is too small") quant <- .C("xsewma_q",as.integer(ctyp),as.double(alpha), as.double(lx),as.double(cx),as.double(hsx),as.integer(Nx), as.double(ls),as.double(csl),as.double(csu),as.double(hss),as.integer(Ns), as.double(mu),as.double(sigma), as.integer(df),as.integer(qm), ans=double(length=1),PACKAGE="spc")$ans names(quant) <- "q" quant } spc/R/xs.res.ewma.arl.R0000644000176200001440000000236513553640534014330 0ustar liggesusers# 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/xDshewhartrunsrulesFixedm.arl.R0000644000176200001440000000116413553640534017413 0ustar liggesusers 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/xewma.crit.R0000644000176200001440000000212513553640534013454 0ustar liggesusers# Computation of EWMA critical values for given ARL (mean monitoring) xewma.crit <- function(l,L0,mu0=0,zr=0,hs=0,sided="one",limits="fix",r=40,c0=NULL) { if ( l<=0 | l>2 ) stop("l has to be between 0 and 2") if ( L0<1 ) stop("L0 is too small") if ( r<4 ) stop("r is too small") if ( sided=="one" & hs 1 ) stop("lambda has to be between 0 and 1") if ( ucl < 0 ) stop("ucl must be larger than 0") if ( sided == "upper" ) lcl <- 0 if ( sided == "lower" ) ucl <- n if ( sided == "two" ) { if ( is.null(lcl) ) stop("lcl must be set") if ( lcl < 0 ) stop("lcl must be larger than 0") } if ( n < 1 ) stop("n must be >= 1") if ( 0 > p | p > 1 ) stop("wrong value for p") if ( is.null(lcl) ) lcl <- 0 if ( z0 < lcl | z0 > ucl ) stop("wrong headstart") ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") 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.integer(ctyp), as.double(lambda), as.double(lcl), 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" arl } spc/R/sewma.arl.R0000644000176200001440000000231413553640534013264 0ustar liggesusers# Computation of EWMA ARLs (variance monitoring) sewma.arl <- function(l, cl, cu, sigma, df, s2.on=TRUE, hs=NULL, sided="upper", r=40, qm=30) { mitte <- sqrt( 2/df ) * gamma( (df+1)/2 )/ gamma( df/2 ) if ( is.null(hs) ) { if ( s2.on ) { hs <- 1 } else { hs <- mitte } } if ( l<=0 || l>1 ) stop("l has to be between 0 and 1") if ( cu<=0 ) stop("cu has to be positive") if ( cl<0 ) stop("cl has to be non-negative") if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") s_squared <- as.numeric(s2.on) if ( !(s_squared %in% c(0,1)) ) stop("wrong value for s2.on") if ( hscu ) stop("wrong headstart") ctyp <- pmatch(sided, c("upper", "Rupper", "two", "Rlower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") if (r<10) stop("r is too small") if (qm<10) stop("qm is too small") arl <- .C("sewma_arl",as.integer(ctyp),as.double(l), as.double(cl),as.double(cu),as.double(hs), as.double(sigma),as.integer(df),as.integer(r),as.integer(qm), as.integer(s_squared), ans=double(length=1),PACKAGE="spc")$ans names(arl) <- "arl" return (arl) } spc/R/pois.cusum.crit.R0000644000176200001440000000153413553640534014443 0ustar liggesusers# Computation of Poisson CUSUM alarm threshold and randomization constant pois.cusum.crit <- function(mu0, km, A, m, i0=0, sided="upper", rando=FALSE) { if ( mu0 < 0 ) stop("mu0 has to be positive") if ( km < 1 ) stop("km has to be >= 1") if ( A < 1 ) stop("A has to be >= 1") if ( m < 1 ) stop("m has to be >= 1") i0 <- round(i0) if ( i0 < 0 | i0 > 100 ) stop("head start i0 has to be an integer in 0, 1, ..., 100") ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1 if ( is.na(ctyp) ) stop("invalid cusum type") cv <- .C("ccusum_crit_be", as.integer(ctyp), as.integer(rando), as.double(mu0), as.integer(km), as.double(A), as.integer(m), as.integer(i0), ans=double(length=2), PACKAGE="spc")$ans names(cv) <- c("hm", "gamma") cv[1] <- as.integer(cv[1]) cv } spc/R/xtewma.sf.R0000644000176200001440000000275213553640534013315 0ustar liggesusers# Computation of EWMA survival function (mean monitoring) xtewma.sf <- function(l, c, df, mu, n, zr=0, hs=0, sided="two", limits="fix", mode="tan", q=1, r=40) { if ( l<=0 || l>1 ) warning("l is typically between 0 and 1 -- you should really know what you do") if ( c <= 0 ) warning("usually, c has to be positive") if ( df < 1 ) stop("df must be greater or equal to 1") if ( n < 1 ) stop("n has to be a natural number") if ( zr > c & sided == "one") stop("wrong reflexion border") if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) ) warning("unusual headstart") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl")) if (is.na(ltyp)) stop("invalid limits type") ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan")) if ( is.na(ntyp) ) stop("substitution type not provided (yet)") if ( r < 4 ) stop("r is too small") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") sf <- .C("xtewma_sf", as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.double(hs), as.integer(df), as.double(mu), as.integer(ltyp), as.integer(r), as.integer(ntyp), as.integer(q), as.integer(n), ans=double(length=n),PACKAGE="spc")$ans names(sf) <- NULL sf } spc/R/imr.arl.C1987b.R0000644000176200001440000000160414252556273013617 0ustar liggesusersimr.arl.C1987b <- function(M, R, mu, sig, N=80) { # original FORTRAN code re-coded in R H <- 2*M/N NN <- N + 1 B <- rep(-1, NN) A <- matrix(NA, nrow=NN, ncol=NN) for ( i in 1:NN ) { U <- -M + H*(i-1) Bi <- min( M, U+R ) Ai <- max(-M, U-R ) N1 <- floor( (Ai+M)/H + 1e-9 ) + 1 N2 <- floor( (Bi+M)/H + 1e-9 ) + 1 for ( j in 1:NN ) { ARG <- Ai + H*(j-N1) A[i,j] <- H * dnorm(ARG, mean=mu, sd=sig) if ( j < N1 ) A[i,j] <- 0 if ( j == N1 ) A[i,j] <- H/2 * dnorm(Ai, mean=mu, sd=sig) if ( j == N2 ) A[i,j] <- H/2 * dnorm(Bi, mean=mu, sd=sig) if ( j > N2 ) A[i,j] <- 0 if ( j == i ) A[i,j] <- A[i,j] - 1 } } X <- solve(A, B) ET <- H/2 * ( dnorm(-M, mean=mu, sd=sig)*X[1] + dnorm(M, mean=mu, sd=sig)*X[NN] ) + 1 for ( i in 2:N ) { ARG <- -M + H*(i-1) ET <- ET + H*X[i]*dnorm(ARG, mean=mu, sd=sig) } ET } spc/R/pois.cusum.crit.L0L1.R0000644000176200001440000000401013612142205015066 0ustar liggesusers# Computation of Poisson CUSUM alarm threshold, randomization constant and target ooc mean (Ewan/Kemp approach) pois.cusum.crit.L0L1 <- function(mu0, L0, L1, sided="upper", OUTPUT=FALSE) { if ( mu0 < 0 ) stop("mu0 has to be positive") if ( L1 <= 1 ) stop("L1 has to be > 1") if ( L0 <= L1 ) stop("L0 has to be > L1") if ( !(sided %in% c("upper", "lower")) ) stop("sided has to be either 'upper' or 'lower'") # helper functions to give the out-of-control mean mu1 for given in-control mean mu0 and reference value k k_m01 <- function(mu0, mu1) (mu1 - mu0) / (log(mu1) - log(mu0)) m1_km0 <- function(mu0, k) { zero <- function(x) k - k_m01(mu0,x) upper <- mu0 + .5 while ( zero(upper) > 0 ) upper <- upper + 0.5 mu1 <- uniroot(zero, c(mu0*1.00000001, upper), tol=1e-9)$root mu1 } L1_1 <- L1 + 1 m1 <- 10 k1 <- mu0 * m1 while ( L1_1 > L1 ) { k1 <- k1 + 1 mu1 <- m1_km0(mu0, k1/m1) cv1 <- pois.cusum.crit(mu0, k1, L0, m1, sided=sided, rando=TRUE) L1_1 <- pois.cusum.arl(mu1, k1, cv1[1], m1, sided=sided, rando=TRUE, gamma=cv1[2]) if ( OUTPUT ) cat(paste("k1 =", k1, ",\tmu1 = ", mu1, ",\tL1 =", L1_1, "\n")) } m1 <- 100 k1 <- 10 * k1 while ( L1_1 < L1 ) { k1 <- k1 - 1 mu1 <- m1_km0(mu0, k1/m1) cv1 <- pois.cusum.crit(mu0, k1, L0, m1, sided=sided, rando=TRUE) L1_1 <- pois.cusum.arl(mu1, k1, cv1[1], m1, sided=sided, rando=TRUE, gamma=cv1[2]) if ( OUTPUT ) cat(paste("k1 =", k1, ",\tmu1 = ", mu1, ",\tL1 =", L1_1, "\n")) } ff <- max(2, ceiling( 3000 / ( cv1[1]/m1 ) ) / m1) m1 <- ff * m1 k1 <- ff * k1 while ( L1_1 > L1 ) { k1 <- k1 + 1 mu1 <- m1_km0(mu0, k1/m1) cv1 <- pois.cusum.crit(mu0, k1, L0, m1, sided=sided, rando=TRUE) L1_1 <- pois.cusum.arl(mu1, k1, cv1[1], m1, sided=sided, rando=TRUE, gamma=cv1[2]) if ( OUTPUT ) cat(paste("k1 =", k1, ",\tmu1 = ", mu1, ",\tL1 =", L1_1, "\n")) } result <- data.frame(m=m1, km=k1, mu1, k=k1/m1, hm=cv1[1], h=cv1[1]/m1, gamma=cv1[2]) result } spc/R/xshewhartrunsrules.matrix.R0000644000176200001440000001206013553640534016675 0ustar liggesusers 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/sewma.crit.prerun.R0000644000176200001440000000413613553640534014765 0ustar liggesusers# Computation of EWMA critical values for given ARL (variance monitoring) with pre-run uncertainty sewma.crit.prerun <- function(l, L0, df1, df2, sigma0=1, cl=NULL, cu=NULL, hs=1, sided="upper", mode="fixed", r=40, qm=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE, c.error=1e-10, a.error=1e-9) { cu0 <- cl0 <- 0 if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( L0<1 ) stop("L0 is too small") if ( df1<1 ) stop("df1 must be positive") if ( df2<1 ) stop("df2 must be positive") if ( sigma0<=0 ) stop("sigma0 must be positive") if ( sided=="Rupper" ) { if ( is.null(cl) ) stop("set cl") if ( cl<=0 ) stop("cl must be positive") cl0 <- cl if ( hs= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") c <- .C("sewma_crit_prerun", as.integer(ctyp), as.integer(ltyp), as.double(l), as.integer(L0), as.double(cl0), as.double(cu0), as.double(hs), as.double(sigma0), as.integer(df1), as.integer(r), as.integer(qm), as.integer(df2), as.integer(qm.sigma), as.double(truncate), as.integer(tail_approx), as.double(c.error), as.double(a.error), ans=double(length=2),PACKAGE="spc")$ans names(c) <- c("cl", "cu") return (c) } spc/R/xewma.arl.R0000644000176200001440000000331713553640534013275 0ustar liggesusers# Computation of EWMA ARLs (mean monitoring) xewma.arl <- function(l, c, mu, zr=0, hs=0, sided="one", limits="fix", q=1, steady.state.mode="conditional", r=40) { if ( l<=0 | l>2 ) stop("l has to be between 0 and 2") if ( c<=0 ) warning("usually, c has to be positive") if ( zr>c & sided=="one" ) stop("wrong reflexion border") if ( (sided=="two" & abs(hs)>c) | (sided=="one" & (hsc)) ) warning("unusual headstart") if ( r<4 ) stop("r is too small") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat", "fink", "limit", "fixW", "fixC")) if ( is.na(ltyp) ) stop("invalid limits type") if ( (sided=="one") & !(limits %in% c("fix", "vacl", "stat", "limit", "fixW")) ) stop("not supported for one-sided EWMA (not reasonable or not implemented yet") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") styp <- pmatch(steady.state.mode, c("conditional", "cyclical")) - 1 if (is.na(styp)) stop("invalid steady.state.mode") if ( limits=="fix" & q>1 & styp==0 ) { 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),as.integer(styp), ans=double(length=q), PACKAGE="spc")$ans } else { arl <- .C("xewma_arl",as.integer(ctyp),as.double(l), as.double(c),as.double(zr),as.double(hs), as.double(mu),as.integer(ltyp),as.integer(r),as.integer(q),as.integer(styp), ans=double(length=1), PACKAGE="spc")$ans } names(arl) <- NULL return (arl) } spc/R/mewma.crit.R0000644000176200001440000000111113553640534013433 0ustar liggesusers# Computation of MEWMA threshold (multivariate mean monitoring) mewma.crit <- function(l, L0, p, hs=0, r=20) { if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( L0<1 ) stop("L0 is too small") if ( p<1 ) stop("wrong dimension parameter") if ( hs<0 ) stop("wrong head start value") if ( r<4 ) stop("resolution too small") h <- .C("mewma_crit", as.double(l), as.double(L0), as.integer(p), as.double(hs), as.integer(r), ans=double(length=1), PACKAGE="spc")$ans names(h) <- NULL h }spc/R/imr.Ru_Rlgiven.R0000644000176200001440000000116014017164623014227 0ustar liggesusersimr.Ru_Rlgiven <- function(Rl, L0, N=30, qm=30, M0=12) { zero <- function(x) imr.arl(M0, x, 0, 1, vsided="two", Rl=Rl, N=N, qm=qm) - L0 Ru1 <- sqrt(2) * qnorm(1-1/(4*L0)) z1 <- zero(Ru1) Ru <- 0 if ( z1 > 0 ) { while ( z1 > 0 ) { Ru2 <- Ru1 Ru1 <- Ru1 / 1.1 z1 <- zero(Ru1) } } else { if ( zero(2*M0-1e-10) > 0 ) { while ( z1 < 0 ) { Ru2 <- Ru1 Ru1 <- Ru1 * 1.1 z1 <- zero(Ru1) } z1 <- Ru1 Ru1 <- Ru2 Ru2 <- z1 } else { Ru <- Inf } } if ( is.finite(Ru) ) Ru <- uniroot(zero, c(Ru1, Ru2), tol=1e-9)$root Ru } spc/R/sewma.arl.prerun.R0000644000176200001440000000246113553640534014601 0ustar liggesusers# Computation of EWMA ARLs (variance monitoring) with pre-run uncertainty sewma.arl.prerun <- function(l, cl, cu, sigma, df1, df2, hs=1, sided="upper", r=40, qm=30, qm.sigma=30, truncate=1e-10) { if ( l<=0 || l>1 ) stop("l has to be between 0 and 1") if ( cl<0 ) stop("cl has to be non-negative") if ( cu<=0 ) stop("cu has to be positive") if ( sigma<=0 ) stop("sigma must be positive") if ( df1<1 ) stop("df1 must be larger than or equal to 1") if ( df2<1 ) stop("df2 must be larger than or equal to 1") if ( hscu ) stop("wrong headstart") ctyp <- pmatch(sided, c("upper", "Rupper", "two", "Rlower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") if ( r<10 ) stop("r is too small") if ( qm<10 ) stop("qm is too small") if ( qm.sigma<4 ) stop("qm.sigma is too small") if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") arl <- .C("sewma_arl_prerun", as.integer(ctyp), as.double(l), as.double(cl), as.double(cu), as.double(hs), as.double(sigma), as.integer(df1), as.integer(r), as.integer(qm), as.integer(df2), as.integer(qm.sigma), as.double(truncate), ans=double(length=1),PACKAGE="spc")$ans names(arl) <- "arl" return (arl) } spc/R/lns2ewma.arl.R0000644000176200001440000000222713553640534013703 0ustar liggesusers# Computation of EWMA ARLs (variance monitoring) based on ln S^2 lns2ewma.arl <- function(l, cl, cu, sigma, df, hs=NULL, sided="upper", r=40) { #mitte <- -1/df - 1/3/df^2 + 2/15/df^4 # approx following Crowder/Hamilton mitte <- log(2/df) + digamma(df/2) if ( is.null(cl) ) cl <- mitte if ( is.null(cu) ) cu <- mitte if ( is.null(hs) ) hs <- mitte if ( l<=0 || l>1 ) stop("l has to be between 0 and 1") #if ( cu < mitte ) stop(paste("cu has to be larger than", mitte)) #if ( cl > mitte ) stop(paste("cl has to be smaller than", mitte)) if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") if ( hscu+1e-9 ) stop("wrong headstart") ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") if ( r<10 ) stop("r is too small") arl <- .C("lns2ewma_arl", as.integer(ctyp), as.double(l), as.double(cl), as.double(cu), as.double(hs), as.double(sigma), as.integer(df), as.integer(r), ans=double(length=1),PACKAGE="spc")$ans names(arl) <- "arl" return (arl) } spc/R/xcusum.crit.L0L1.R0000644000176200001440000000222213553640534014324 0ustar liggesusers # 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/quadrature.nodes.weights.R0000644000176200001440000000104113553640534016324 0ustar liggesusersquadrature.nodes.weights <- function(n, type="GL", x1=-1, x2=1) { if ( n < 1 ) stop("n has to be a natural number") qtyp <- pmatch(type, c("GL", "Ra")) - 1 if ( is.na(qtyp) ) stop("invalid quadrature type") if ( x1 >= x2 ) stop("x1 must be smaller than x2") nw <- .C("quadrature_nodes_weights", as.integer(n), as.double(x1), as.double(x2), as.integer(qtyp), ans=double(length=2*n), PACKAGE="spc")$ans qnw <- data.frame(nodes=nw[1:n], weights=nw[-(1:n)]) qnw }spc/R/xewma.q.crit.R0000644000176200001440000000200713553640534013712 0ustar liggesusersxewma.q.crit <- function(l, L0, mu, alpha, zr=0, hs=0, sided="two", limits="fix", r=40, c.error=1e-12, a.error=1e-9, OUTPUT=FALSE) { c2 <- 0 p2 <- 1 if ( OUTPUT ) cat("\nc\t\tp\n") while ( p2 > alpha ) { p1 <- p2 c2 <- c2 + .5 p2 <- 1 - xewma.sf(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } while ( p2 <= alpha & c2 > .02 ) { p1 <- p2 c2 <- c2 - .02 p2 <- 1 - xewma.sf(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } c1 <- c2 + .02 a.error_ <- 1; c.error_ <- 1 while ( a.error_ > a.error & c.error_ > c.error ) { c3 <- c1 + (alpha - p1)/(p2 - p1)*(c2 - c1) p3 <- 1 - xewma.sf(l, c3, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, r=r)[L0] if ( OUTPUT ) cat(paste(c3,"\t",p3,"\n")) c1 <- c2; c2 <- c3 p1 <- p2; p2 <- p3 a.error_ <- abs(p2 - alpha); c.error_ <- abs(c2 - c1) } names(c3) <- "c" c3 } spc/R/xshewhartrunsrules.ad.R0000644000176200001440000000102113553640534015750 0ustar liggesusers 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/lns2ewma.crit.R0000644000176200001440000000344413553640534014070 0ustar liggesusers# Computation of EWMA critical values for given ARL (variance monitoring) based on ln S^2 lns2ewma.crit <- function(l, L0, df, sigma0=1, cl=NULL, cu=NULL, hs=NULL, sided="upper", mode="fixed", r=40) { #mitte <- -1/df - 1/3/df^2 + 2/15/df^4 # approx following Crowder/Hamilton mitte <- log(2/df) + digamma(df/2) if ( is.null(hs) ) hs <- mitte cu0 <- cl0 <- 0 if ( l<=0 || l>1 ) stop("l has to be between 0 and 1") if ( L0<1 ) stop("L0 is too small") if ( df<1 ) stop("df must be positive") if ( sigma0<=0 ) stop("sigma0 must be positive") if ( sided=="upper" ) { if ( is.null(cl) ) cl <- mitte #if ( cl > mitte + 1e-9 ) stop(paste("cl has to be smaller than", mitte)) cl0 <- cl if ( hscu0+1e-9 ) stop("hs must not be larger than cu") } if (sided=="two" & mode=="fixed") { if ( is.null(cu) ) stop("set cu") #if ( cu < mitte - 1e-9 ) stop(paste("cu has to be larger than", mitte)) cu0 <- cu if ( hs>cu0+1e-9 ) stop("hs must not be larger than cu") } ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1 if (is.na(ctyp)) stop("invalid ewma type") ltyp <- pmatch(mode, c("fixed", "unbiased", "eq.tails", "vanilla")) - 1 if (is.na(ltyp)) stop("invalid limits type") if ( r<10 ) stop("r is too small") c <- .C("lns2ewma_crit", as.integer(ctyp), as.integer(ltyp), as.double(l), as.double(L0), as.double(cl0), as.double(cu0), as.double(hs), as.double(sigma0), as.integer(df), as.integer(r), ans=double(length=2),PACKAGE="spc")$ans names(c) <- c("cl", "cu") return (c) } spc/R/xshewhartrunsrules.arl.R0000644000176200001440000000062313553640534016151 0ustar liggesusers 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/pois.ewma.arl.R0000644000176200001440000000253113652235707014055 0ustar liggesusers# Computation of Poisson EWMA ARLs pois.ewma.arl <- function(lambda, AL, AU, mu0, z0, mu, sided="two", rando=FALSE, gL=0, gU=0, mcdesign="transfer", N=101) { if ( lambda <= 0 | lambda > 1 ) stop("lambda has to be between 0 and 1") if ( AL < 0 | AU < 0 ) stop("control limit factors must be positive") if ( mu0 < 0 ) stop("wrong value for mu0") if ( mu < 0 ) stop("wrong value for mu") hL <- mu0 - AL*sqrt(lambda*mu0/(2-lambda)) hU <- mu0 + AU*sqrt(lambda*mu0/(2-lambda)) if ( z0 < hL | z0 > hU ) stop("wrong headstart") ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") mcd <- pmatch(mcdesign, c("classic", "transfer", "cW", "tW")) - 1 if ( is.na(mcd) ) stop("invalid mcdesign value") if ( rando ) { if ( gL < 0 | gL > 1 ) stop("wrong value for gL") if ( gU < 0 | gU > 1 ) stop("wrong value for gU") } arl <- .C("cewma_arl_be", as.integer(ctyp), as.integer(mcd), as.integer(rando), as.double(lambda), as.double(AL), as.double(AU), as.double(gL), as.double(gU), as.double(mu0), as.double(z0), as.double(mu), as.integer(N), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- "arl" arl } spc/R/phat.ewma.arl.R0000644000176200001440000000272513553640534014042 0ustar liggesusers# Computation of EWMA phat ARLs phat.ewma.arl <- function(lambda, ucl, mu, n, z0, sigma=1, type="known", LSL=-3, USL=3, N=15, qm=25, ntype="coll") { if ( lambda <= 0 || lambda > 1 ) stop("lambda has to be between 0 and 1") p.star <- pnorm( LSL ) + pnorm( -USL ) if ( type == "known" ) { if ( ucl <= p.star ) stop("ucl must be larger than p.star") } if ( type == "estimated" ) { p.star <- 0 if ( ucl <= 0 ) stop("ucl must be positive") } if ( ucl >= 1 ) stop("ucl must be smaller than 1") if ( n < 1 ) stop("n must be >= 1") if ( z0 < p.star | z0 > ucl ) stop("wrong headstart") if ( sigma<1e-12 ) stop("sigma much too small") ctyp <- -1 + pmatch(tolower(type), c("known", "estimated")) if ( is.na(ctyp) ) stop("invalid sigma mode") if ( LSL >= USL ) stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)") if ( N < 2 ) stop("N too small") if ( qm < 5 ) stop("qm too small") ntyp <- -1 + pmatch(tolower(ntype), c("coll", "markov")) if ( is.na(ntyp) ) stop("wrong label for numerical algorithm") arl <- .C("ewma_phat_arl_coll", as.double(lambda), as.double(ucl), as.double(mu), as.double(sigma), as.integer(n), as.double(z0), as.integer(ctyp), as.double(LSL), as.double(USL), as.integer(N), as.integer(qm), as.integer(ntyp), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- "arl" arl }spc/R/xgrsr.ad.R0000644000176200001440000000117613553640534013130 0ustar liggesusers# Computation of GRSR (Girshick, Rubin, Shiryaev, Roberts) steady-state ARLs (mean monitoring) xgrsr.ad <- function(k, g, mu1, mu0=0, zr=0, sided="one", MPT=FALSE, r=30) { if (k<0) stop("k has to be non-negative") if (g<0) stop("g has to be positive") if (r<4) stop("r is too small") ctyp <- pmatch(sided, c("one", "two")) - 1 if (is.na(ctyp)) stop("invalid grsr type") ad <- .C("xgrsr_ad",as.integer(ctyp),as.double(k), as.double(g),as.double(mu0),as.double(mu1),as.double(zr),as.integer(r),as.integer(MPT), ans=double(length=1),PACKAGE="spc")$ans names(ad) <- "ad" return(ad) } spc/R/xshewhart.ar1.arl.R0000644000176200001440000000073113553640534014650 0ustar liggesusers# Computation of the ARL for modified Shewhart charts, AR(1) data xshewhart.ar1.arl <- function(alpha, cS, delta=0, N1=50, N2=30) { if ( abs(alpha) >= 1 ) stop("alpha has to be between -1 and 1") if ( cS <= 0 ) stop("cS has to be positive") arl <- .C("xshewhart_ar1_arl", as.double(alpha), as.double(cS), as.double(delta), as.integer(N1), as.integer(N2), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- NULL arl } spc/R/xewma.q.prerun.R0000644000176200001440000000437413553640534014275 0ustar liggesusers# Computation of EWMA quantiles (mean monitoring) under specified pr-run scenarios xewma.q.prerun <- function(l, c, mu, p, zr=0, hs=0, sided="two", limits="fix", q=1, size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, bound=1e-10) { if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1") if ( c<=0 ) warning("usually, c has to be positive") if ( p <= 0 | p >= 1) stop("quantile level p must be in (0,1)") if ( zr > c & sided == "one") stop("wrong reflexion border") if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) ) stop("wrong headstart") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat")) if (is.na(ltyp)) stop("invalid limits type") if ( (sided=="one") & !( limits %in% c("fix", "vacl", "stat") ) ) stop("not supported for one-sided EWMA (not reasonable or not implemented yet") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") if ( size<2 ) stop("pre run size too small") if ( is.null(df) ) df = size - 1 if ( df<1 ) stop("degrees of freedom (df) too small") emode <- -1 + pmatch(estimated, c("mu", "sigma", "both")) if (is.na(emode)) stop("invalid to be estimated type") if ( qm.mu<4 ) stop("qm.mu is too small") if ( qm.sigma<4 ) stop("qm.sigma is too small") if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") if ( bound < 0 | bound >= 0.001 ) stop("wrong value for bound (should follow 0 < truncate < 0.001)") quant <- .C("xewma_q_prerun", as.integer(ctyp), as.double(l), as.double(c), as.double(p), as.double(zr), as.double(hs), as.double(mu), as.integer(ltyp), as.integer(q), as.integer(size), as.integer(df), as.integer(emode), as.integer(qm.mu), as.integer(qm.sigma), as.double(truncate), as.double(bound), ans=double(length=1),PACKAGE="spc")$ans names(quant) <- "q" quant } spc/R/imr.RuRl_alone.R0000644000176200001440000000167414017226177014232 0ustar liggesusersimr.RuRl_alone <- function(L0, N=30, qm=30, M0=12, eps=1e-3) { zero <- Vectorize(function(x) { Ru1 <- imr.Ru_Rlgiven(x, L0, N=N, qm=qm, M0=M0) Lp <- imr.arl(M0, Ru1, 0, 1+eps, vsided="two", Rl=x, N=N, qm=qm) Lm <- imr.arl(M0, Ru1, 0, 1-eps, vsided="two", Rl=x, N=N, qm=qm) DELTA <- (Lp-Lm)/(2*eps) }) pivot <- imr.Rl_Mgiven(M0, L0, N=N, qm=qm) Rl1 <- pivot / 2 D1 <- zero(Rl1) Rl <- 1 if ( D1 < 0 ) { while ( D1 < 0 & Rl1 < pivot/1.1 ) { Rl2 <- Rl1 Rl1 <- Rl1 * 1.1 D1 <- zero(Rl1) D1 } if ( D1 > 0 ) { D1 <- Rl1 Rl1 <- Rl2 Rl2 <- D1 } else { Rl <- 0 } } else { while ( D1 > 0 ) { Rl2 <- Rl1 Rl1 <- Rl1 / 1.1 D1 <- zero(Rl1) } } if ( Rl > 0 ) { Rl <- uniroot(zero, c(Rl1, Rl2), tol=1e-9)$root Ru <- imr.Ru_Rlgiven(Rl, L0, N=N, qm=qm, M0=M0) } else { Ru <- 3*M0 # like infinity Rl <- pivot } c(Rl, Ru) } spc/R/xcusum.crit.L0h.R0000644000176200001440000000156013553640534014303 0ustar liggesusers # 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/phat.ewma.crit.R0000644000176200001440000000221413553640534014216 0ustar liggesusers# Computation of EWMA phat upper control limits phat.ewma.crit <- function(lambda, L0, mu, n, z0, sigma=1, type="known", LSL=-3, USL=3, N=15, qm=25) { if ( lambda <= 0 || lambda > 1 ) stop("lambda has to be between 0 and 1") p.star <- pnorm( LSL/sigma ) + pnorm( -USL/sigma ) if ( type == "estimated" ) p.star <- 0 if ( L0 < 1 ) stop("L0 is too small") if ( n < 1 ) stop("n must be >= 1") if ( z0 < p.star & z0 >= 1 ) stop("wrong headstart") if ( sigma<1e-10 ) stop("sigma much too small") ctyp <- -1 + pmatch(type, c("known", "estimated")) if ( is.na(ctyp) ) stop("invalid sigma mode") if ( LSL >= USL ) stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)") if ( N < 3 ) stop("N too small") if ( qm < 5 ) stop("qm too small") ucl <- .C("ewma_phat_crit_coll", as.double(lambda), as.double(L0), as.double(mu), as.double(sigma), as.integer(n), as.double(z0), as.integer(ctyp), as.double(LSL), as.double(USL), as.integer(N), as.integer(qm), ans=double(length=1), PACKAGE="spc")$ans names(ucl) <- "ucl" ucl }spc/R/tewma.arl.R0000644000176200001440000000151413553640534013266 0ustar liggesusers# Computation of TEWMA ARLs for iid Poisson tewma.arl <- function(lambda, k, lk, uk, mu, z0, rando=FALSE, gl=0, gu=0) { if ( lambda <= 0 || lambda > 1 ) stop("lambda has to be between 0 and 1") if ( k < 1 ) stop("k must be >= 1") if ( mu < 0 ) stop("mu must be positive") if ( lk > z0 | z0 > uk ) stop("wrong headstart") if ( 0 > gl | gl > 1 ) stop("wrong value for gl") if ( 0 > gu | gu > 1 ) stop("wrong value for gu") irando <- as.numeric(rando) arl <- .C("tewma_arl_wowR", as.integer(irando), as.double(lambda), as.integer(k), as.integer(lk), as.integer(uk), as.double(gl), as.double(gu), as.double(z0), as.double(mu), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- "arl" arl } spc/R/imr.arl.Ny.R0000644000176200001440000000220414016130126013304 0ustar liggesusersimr.arl.Ny <- function(M, R, mu, N, kind="gl") { phij <- function(x,y) ifelse(abs(y-x)<=R, dnorm(y, mean=mu), 0) one <- rep(1, N) I <- diag(1, N) if ( kind == "gl" ) { GQ <- quadrature.nodes.weights(N, x1=-M, x2=M) z <- GQ$nodes w <- GQ$weights } if ( kind == "rectangular" ) { b <- 2*M/N z <- -M + (0:(N-1) + .5)*b w <- rep(b, N) } if ( kind %in% c("trapezoid", "simpson", "simpson3_8") ) { b <- 2*M/(N-1) z <- -M + (0:(N-1))*b w <- 1:N } if ( kind == "trapezoid" ) { w <- rep(2, N) w[c(1, N)] <- 1 w <- w * b/2 } if ( kind == "simpson" ) { w <- 4*((w %% 2) == 0) + 2*((w %% 2) == 1) w[c(1, N)] <- 1 w <- w * b/3 } if ( kind == "simpson3_8" ) { w <- 3*((w %% 3) != 1) + 2*((w %% 3) == 1) w[c(1, N)] <- 1 w <- w * 3*b/8 } Q <- outer(z,z,phij)*t(array(w,c(N,N))) vLu <- solve(I-Q, one) Lu <- Vectorize(function(x) { 1 + ( phij(x,z) * w ) %*% vLu }) integrand <- function(x) Lu(x) * dnorm(x, mean=mu) GQ2 <- quadrature.nodes.weights(200, x1=-M, x2=M) z2 <- GQ2$nodes w2 <- GQ2$weights ET <- 1 + sum( w2 * integrand(z2) ) ET } spc/R/sewma.sf.prerun.R0000644000176200001440000000261613553640534014435 0ustar liggesusers# Computation of EWMA survival function (variance monitoring) with pre-run uncertainty sewma.sf.prerun <- function(n, l, cl, cu, sigma, df1, df2, hs=1, sided="upper", qm=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE) { if ( n < 1 ) stop("n has to be a natural number") if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1") if ( cu<=0 ) stop("cu has to be positive") if ( cl<0 ) stop("cl has to be non-negative") if ( sided!="upper" & cl<1e-6 ) stop("cl is too small") if ( sigma<=0 ) stop("sigma must be positive") if ( df1<1 ) stop("df1 must be larger than or equal to 1") if ( df2<1 ) stop("df2 must be larger than or equal to 1") if ( hscu ) stop("wrong headstart hs") ctyp <- pmatch(sided, c("upper","Rupper","two","Rlower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") if ( qm<5 ) stop("qm is too small") if ( qm.sigma<4 ) stop("qm.sigma is too small") if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") sf <- .C("sewma_sf_prerun", as.integer(ctyp), as.double(l), as.double(cl), as.double(cu), as.double(hs), as.double(sigma), as.integer(df1), as.integer(qm), as.integer(n), as.integer(df2), as.integer(qm.sigma), as.double(truncate), as.integer(tail_approx), ans=double(length=n),PACKAGE="spc")$ans names(sf) <- NULL sf } spc/R/s.res.ewma.arl.R0000644000176200001440000000162513553640534014136 0ustar liggesusers# 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/xsewma.crit.R0000644000176200001440000000315413553640534013642 0ustar liggesusers# Computation of EWMA critical values for given ARL # (simultaneous mean and variance monitoring) xsewma.crit <- function(lx, ls, L0, df, mu0=0, sigma0=1, cu=NULL, hsx=0, hss=1, s2.on=TRUE, sided="upper", mode="fixed", Nx=30, Ns=40, qm=30) { if (lx<=0 || lx>1) stop("lx has to be between 0 and 1") if (ls<=0 || ls>1) stop("ls has to be between 0 and 1") if (L0<1) stop("L0 is too small") if (sigma0<=0) stop("sigma0 must be positive") if (mode=="fixed" & sided=="two") { if (is.null(cu)) stop("set cu") if (cucu) stop("hs must be smaller than cu") cu0 <- cu } else { cu0 <- 0 } if (df<1) stop("df must be positive") s_squared <- as.numeric(s2.on) if ( !(s_squared %in% c(0,1)) ) stop("wrong value for s2.on") ctyp <- pmatch(sided, c("upper","Rupper","two","lower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") ltyp <- pmatch(mode, c("fixed","unbiased")) - 1 if (is.na(ltyp)) stop("invalid limits type") if (Nx<5) stop("r.x is too small") if (Ns<10) stop("r.s is too small") if (qm<10) stop("qm is too small") c <- .C("xsewma_crit",as.integer(ctyp),as.integer(ltyp), as.double(lx),as.double(ls), as.double(L0),as.double(cu0),as.double(hsx),as.double(hss), as.double(mu0),as.double(sigma0), as.integer(df),as.integer(Nx),as.integer(Ns), as.integer(qm), ans=double(length=3),PACKAGE="spc")$ans names(c) <- c("cx","cl","cu") return (c) } spc/R/xewma.ad.R0000644000176200001440000000235613553640534013105 0ustar liggesusers# Computation of EWMA steady-state ARLs (mean monitoring) xewma.ad <- function(l, c, mu1, mu0=0, zr=0, z0=0, sided="one", limits="fix", steady.state.mode="conditional", r=40) { if ( l<=0 || l>1 ) stop("l has to be between 0 and 1") if ( c<=0 ) warning("usually, c has to be positive") if ( zr>c & sided=="one" ) stop("wrong reflexion border") if ( r<4 ) stop("r is too small") ctyp <- pmatch(sided, c("one", "two")) - 1 if (is.na(ctyp)) stop("invalid ewma type") ltyp <- pmatch(limits, c("fix","vacl","fir","both","Steiner","stat")) - 1 if ( is.na(ltyp) ) stop("invalid limits type") if ( (sided=="one") & !(limits %in% c("fix", "vacl", "stat")) ) stop("not supported for one-sided EWMA (not reasonable or not implemented yet") styp <- pmatch(steady.state.mode, c("conditional", "cyclical")) - 1 if (is.na(styp)) stop("invalid steady.state.mode") if ( abs(z0) > abs(c) ) stop("wrong restarting value") ad <- .C("xewma_ad", as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.double(mu0), as.double(mu1), as.double(z0), as.integer(ltyp), as.integer(styp), as.integer(r), ans=double(length=1), PACKAGE="spc")$ans names(ad) <- "ad" return (ad) } spc/R/xgrsr.crit.R0000644000176200001440000000120714310375145013473 0ustar liggesusers# Computation of GRSR (Girshick, Rubin, Shiryaev, Roberts) alarm threshold for given ARL (mean monitoring) xgrsr.crit <- function(k, L0, mu0=0, zr=0, hs=NULL, sided="one", MPT=FALSE, r=30) { if ( k<0 ) stop("k has to be non-negative") if ( L0<1 ) stop("L0 is too small") if ( !is.null(hs) ) { if ( hs>2*log(L0) ) stop("wrong headstart") } else { hs <- 2*L0 } if ( r<4 ) stop("r is too small") g <- .C("xgrsr_crit",as.double(k), as.double(L0),as.double(zr),as.double(hs),as.double(mu0),as.integer(r),as.integer(MPT), ans=double(length=1),PACKAGE="spc")$ans names(g) <- "g" return (g) } spc/R/xtewma.ad.R0000644000176200001440000000241613553640534013266 0ustar liggesusers# Computation of EWMA steady-state ARLs (mean monitoring, t distributed data) xtewma.ad <- function(l, c, df, mu1, mu0=0, zr=0, z0=0, sided="one", limits="fix", steady.state.mode="conditional", mode="tan", r=40) { if ( l<=0 || l>1 ) warning("l has to be between 0 and 1") if ( c<=0 ) warning("usually, c has to be positive") if ( zr>c & sided=="one" ) stop("wrong reflexion border") if ( r<4 ) stop("r is too small") ctyp <- pmatch(sided, c("one", "two")) - 1 if (is.na(ctyp)) stop("invalid ewma type") ltyp <- pmatch(limits, c("fix","vacl")) - 1 if ( is.na(ltyp) ) stop("invalid limits type") styp <- pmatch(steady.state.mode, c("conditional", "cyclical")) - 1 if (is.na(styp)) stop("invalid steady.state.mode") if ( abs(z0) > abs(c) ) stop("wrong restarting value") ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan")) if ( is.na(ntyp) ) stop("substitution type not provided (yet)") ad <- .C("xtewma_ad", as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.integer(df), as.double(mu0), as.double(mu1), as.double(z0), as.integer(ltyp), as.integer(styp), as.integer(r), as.integer(ntyp), ans=double(length=1), PACKAGE="spc")$ans names(ad) <- "ad" return (ad) } spc/R/xcusum.sf.R0000644000176200001440000000130413553640534013324 0ustar liggesusers# 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/xtshewhart.ar1.arl.R0000644000176200001440000000132713553640534015036 0ustar liggesusers# Computation of the ARL for modified Shewhart charts, AR(1) data xtshewhart.ar1.arl <- function(alpha, cS, df, delta=0, N1=50, N2=30, N3=2*N2, INFI=10, mode="tan") { if ( abs(alpha) >= 1 ) stop("alpha has to be between -1 and 1") if ( cS <= 0 ) stop("cS has to be positive") ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan")) if ( is.na(ntyp) ) stop("substitution type not provided (yet) or simply wrong") arl <- .C("tshewhart_ar1_arl", as.double(alpha), as.double(cS), as.double(delta), as.integer(df), as.integer(N1), as.integer(N2), as.integer(N3), as.double(INFI), as.integer(ntyp), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- NULL arl } spc/R/scusum.arl.R0000644000176200001440000000243013553640534013466 0ustar liggesusers# Computation of CUSUM ARLs (variance monitoring) scusum.arl <- function(k, h, sigma, df, hs=0, sided="upper", k2=NULL, h2=NULL, hs2=0, r=40, qm=30, version=2) { if ( k<0 ) stop("k has to be non-negative") if ( h<=0 ) stop("h has to be positive") if ( hs<0 | hs>h ) stop("wrong headstart") if ( sided=="two" ) { if ( is.null(k2) | is.null(h2) ) stop("in case of a two-sided CUSUM scheme one has to define two sets of (k,h,hs)") if ( k2<0 ) stop("k2 has to be non-negative") if ( h2<=0 ) stop("h2 has to be positive") if ( hs2<0 | hs2>h2 ) stop("wrong headstart") } if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1 if ( is.na(ctyp) ) stop("invalid cusum type") if ( r<10 ) stop("r is too small") if ( qm<10 ) stop("qm is too small") arl <- .C("scusum_arl", as.integer(ctyp), as.double(k), as.double(h), as.double(hs), as.double(sigma), as.integer(df), as.double(k2), as.double(h2), as.double(hs2), as.integer(r), as.integer(qm), as.integer(version), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- "arl" arl } spc/R/imr.MandRuRl.R0000644000176200001440000000152114017233472013637 0ustar liggesusersimr.MandRuRl <- function(L0, N=30, qm=30) { Xarl <- function(M) 1/(2*pnorm(-M)) MRarl <- function(Ru, Rl, N=N, qm=qm) imr.arl(12, Ru, 0, 1, vsided="two", Rl=Rl, N=N, qm=qm) M0 <- qnorm(1-1/(2*L0)) M1 <- M0 + .1 delta <- Vectorize(function(x) { LM <- Xarl(x) RRR <- imr.RuRl_alone(L0, N=N, qm=qm, M0=x) LR <- MRarl(RRR[2], RRR[1], N=N, qm=qm) LM - LR }) D1 <- delta(M1) if ( D1 > 0 ) { while ( D1 > 0 ) { M2 <- M1 M1 <- mean(c(M0,M1)) D1 <- delta(M1) } } else { while ( D1 < 0 ) { M2 <- M1 M1 <- M1 + 0.1 D1 <- delta(M1) } while ( D1 > 0 ) { M2 <- M1 M1 <- M1 - 0.02 D1 <- delta(M1) } } M <- uniroot(delta, c(M1, M2), tol=1e-9)$root RRR <- imr.RuRl_alone(L0, N=N, qm=qm, M0=M) Rl <- RRR[1] Ru <- RRR[2] c(M, Rl, Ru) } spc/R/xshewhartrunsrules.crit.R0000644000176200001440000000110613553640534016331 0ustar liggesusers 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/sewma.sf.R0000644000176200001440000000204213553640534013114 0ustar liggesusers# Computation of EWMA survival function (variance monitoring) sewma.sf <- function(n, l, cl, cu, sigma, df, hs=1, sided="upper", r=40, qm=30) { if ( n < 1 ) stop("n has to be a natural number") if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1") if ( cu<=0 ) stop("cu has to be positive") if ( cl<0 ) stop("cl has to be non-negative") if ( sided!="upper" & cl<1e-6 ) stop("cl is too small") if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") if ( hscu ) stop("wrong headstart hs") if ( r<10 ) stop("r is too small") ctyp <- pmatch(sided, c("upper","Rupper","two","Rlower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") if ( qm<5 ) stop("qm is too small") sf <- .C("sewma_sf", as.integer(ctyp), as.double(l), as.double(cl), as.double(cu), as.double(hs), as.integer(r), as.double(sigma), as.integer(df), as.integer(qm), as.integer(n), ans=double(length=n),PACKAGE="spc")$ans names(sf) <- NULL sf } spc/R/imr.Ru_Mgiven.R0000644000176200001440000000036214017233602014043 0ustar liggesusers imr.Ru_Mgiven <- function(M, L0, N=30, qm=30) { M0 <- qnorm( 1-1/(2*L0) ) if ( M > M0 ) { zero <- function(x) imr.arl(M, x, 0, 1, N=N, qm=qm) - L0 Ru <- uniroot(zero, c(M0, 10), tol=1e-9)$root } else { Ru <- Inf } Ru } spc/R/sewma.q.R0000644000176200001440000000214413553640534012747 0ustar liggesusers# Computation of EWMA quantiles (variance monitoring) sewma.q <- function(l, cl, cu, sigma, df, alpha, hs=1, sided="upper", r=40, qm=30) { if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1") if ( cu<=0 ) stop("cu has to be positive") if ( cl<0 ) stop("cl has to be non-negative") if ( sided!="upper" & cl<1e-6 ) stop("cl is too small") if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)") if ( hscu ) stop("wrong headstart hs") ctyp <- pmatch(sided, c("upper","Rupper","two","Rlower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") if ( r<10 ) stop("r is too small") if ( qm<5 ) stop("qm is too small") quant <- .C("sewma_q", as.integer(ctyp), as.double(l), as.double(cl), as.double(cu), as.double(alpha), as.double(hs), as.integer(r), as.double(sigma), as.integer(df), as.integer(qm), ans=double(length=1),PACKAGE="spc")$ans names(quant) <- "q" quant } spc/R/imr.RuRl_alone_s3.R0000644000176200001440000000106714017164760014632 0ustar liggesusersimr.RuRl_alone_s3 <- function(L0, N=30, qm=30, M0=12) { zero <- Vectorize(function(x) imr.arl(M0, x, 0, 1, vsided="two", Rl=1/x^3, N=N, qm=qm) - L0) Ru1 <- sqrt(2) * qnorm( 1-1/(4*L0) ) D1 <- zero(Ru1) if ( D1 < 0 ) { while ( D1 < 0 ) { Ru2 <- Ru1 Ru1 <- Ru1 * 1.1 D1 <- zero(Ru1) } D1 <- Ru1 Ru1 <- Ru2 Ru2 <- D1 } else { while ( D1 > 0 ) { Ru2 <- Ru1 Ru1 <- Ru1 / 1.1 D1 <- zero(Ru1) } } Ru <- uniroot(zero, c(Ru1, Ru2), tol=1e-9)$root Rl <- 1/Ru^3 c(Rl, Ru) } spc/R/scusum.crit.R0000644000176200001440000000270613553640534013657 0ustar liggesusers# Computation of CUSUM decision intervals -- alarm thresholds -- (variance monitoring) scusum.crit <- function(k, L0, sigma, df, hs=0, sided="upper", mode="eq.tails", k2=NULL, hs2=0, r=40, qm=30) { if ( k<0 ) stop("k has to be non-negative") if ( L0<1 ) stop("L0 is too small") if ( hs<0 ) stop("wrong headstart") if ( sided=="two" ) { if ( is.null(k2) ) stop("in case of a two-sided CUSUM scheme one has to define two reference values") if ( k2<0 ) stop("k2 has to be non-negative") if ( hs2<0 ) stop("wrong headstart") } if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1 if ( is.na(ctyp) ) stop("invalid cusum type") ltyp <- pmatch(mode, c("eq.tails", "unbiased")) - 1 if ( is.na(ltyp) ) stop("invalid limits cusum type") if ( r<10 ) stop("r is too small") if ( qm<10 ) stop("qm is too small") a.length <- 1 if ( sided=="two" ) a.length <- 2 h <- .C("scusum_crit", as.integer(ctyp), as.double(k), as.double(L0), as.double(hs), as.double(sigma), as.integer(df), as.integer(ltyp), as.double(k2), as.double(hs2), as.integer(r), as.integer(qm), ans=double(length=a.length), PACKAGE="spc")$ans if ( sided=="two" ) { names(h) <- c("hl","hu") } else { names(h) <- "h" } h } spc/R/pphat.R0000644000176200001440000000176013553640534012513 0ustar liggesuserspphat <- function(q, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30) { if ( n < 1 ) stop("n must be >= 1") if ( sigma<1e-10 ) stop("sigma much too small") ctyp <- -1 + pmatch(type, c("known", "estimated")) if ( is.na(ctyp) ) stop("invalid sigma mode") if ( LSL >= USL ) stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)") if ( nodes<2 ) stop("far too less nodes") p.star <- pnorm( LSL/sigma ) + pnorm( -USL/sigma ) if ( type == "estimated" ) p.star <- 0 cdf <- rep(NA, length(q)) for ( i in 1:length(q) ) { cdf[i] <- 0 if ( q[i] >= 1 ) cdf[i] <- 1 if ( p.star= 1") if ( z0 < p.star & z0 >= 1 ) stop("wrong headstart") if ( sigma<1e-12 ) stop("sigma much too small") ctyp <- -1 + pmatch(type, c("known", "estimated")) if ( is.na(ctyp) ) stop("invalid sigma mode") if ( max_l < min_l | max_l > 1 ) stop("wrong value for max_l (or min_l)") if ( min_l < 1e-4 ) stop("min_l too small") if ( LSL >= USL ) stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)") if ( qm < 5 ) stop("qm too small") lambda <- .C("ewma_phat_lambda_coll", as.double(L0), as.double(mu), as.double(sigma), as.integer(ctyp), as.double(max_l), as.double(min_l), as.integer(n), as.double(z0), as.double(LSL), as.double(USL), as.integer(qm), ans=double(length=1), PACKAGE="spc")$ans names(lambda) <- "lambda" lambda }spc/R/xcusum.ad.R0000644000176200001440000000134413553640534013304 0ustar liggesusers# Computation of CUSUM steady-state ARLs (mean monitoring) xcusum.ad <- function(k, h, mu1, mu0 = 0, sided = "one", r = 30) { if (k<0) stop("k has to be non-negative") if (h<=0) stop("h has to be positive") if (r<4) stop("r is too small") if (r>30 & r<=50 & sided=="two") warning("computation needs some time") if (r>50 & sided=="two") warning("ought to be restricted to very fast CPUs") ctyp <- pmatch(sided, c("one", "two", "Crosier")) - 1 if (is.na(ctyp)) stop("invalid cusum type") ad <- .C("xcusum_ad",as.integer(ctyp),as.double(k), as.double(h),as.double(mu0),as.double(mu1),as.integer(r), ans=double(length=1),PACKAGE="spc")$ans names(ad) <- "ad" return(ad) } spc/R/sewma.q.crit.prerun.R0000644000176200001440000000434613553640534015227 0ustar liggesusers# Computation of EWMA critical values for given QRL (variance monitoring) with pre-run uncertainty sewma.q.crit.prerun <- function(l, L0, alpha, df1, df2, sigma0=1, cl=NULL, cu=NULL, hs=1, sided="upper", mode="fixed", r=40, qm=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE, c.error=1e-10, a.error=1e-9) { cu0 <- cl0 <- 0 if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( L0<1 ) stop("L0 is too small") if ( alpha<=0 | alpha>=1 ) stop("quantile level alpha must be in (0,1)") if ( df1<1 ) stop("df1 must be positive") if ( df2<1 ) stop("df2 must be positive") if ( sigma0<=0 ) stop("sigma0 must be positive") if ( sided=="Rupper" ) { if ( is.null(cl) ) stop("set cl") if ( cl<=0 ) stop("cl must be positive") cl0 <- cl if ( hs= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") c <- .C("sewma_q_crit_prerun", as.integer(ctyp), as.integer(ltyp), as.double(l), as.integer(L0), as.double(alpha), as.double(cl0), as.double(cu0), as.double(hs), as.double(sigma0), as.integer(df1), as.integer(r), as.integer(qm), as.integer(df2), as.integer(qm.sigma), as.double(truncate), as.integer(tail_approx), as.double(c.error), as.double(a.error), ans=double(length=2),PACKAGE="spc")$ans names(c) <- c("cl", "cu") return (c) } spc/R/tol.lim.fac.R0000644000176200001440000000113213553640534013476 0ustar liggesusers# 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/pois.ewma.crit.R0000644000176200001440000000253113553640534014236 0ustar liggesusers# Computation of Poisson EWMA control limits pois.ewma.crit <- function(lambda, L0, mu0, z0, AU=3, sided="two", design="sym", rando=FALSE, mcdesign="transfer", N=101, jmax=4) { if ( lambda <= 0 | lambda > 1 ) stop("lambda has to be between 0 and 1") if ( L0 < 1 ) stop("L0 has to be larger") if ( mu0 < 0 ) stop("wrong value for mu0") ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") dtyp <- pmatch(design, c("sym", "unb")) - 1 if ( is.na(dtyp) ) stop("invalid design type") mcd <- pmatch(mcdesign, c("classic", "transfer")) - 1 if ( is.na(mcd) ) stop("invalid mcdesign value") LL <- ifelse(dtyp==0, 1, 2) if (dtyp==1 & rando) LL <- 4 crit <- .C("cewma_crit_be", as.integer(ctyp), as.integer(dtyp), as.integer(mcd), as.integer(rando), as.double(lambda), as.double(L0), as.double(AU), as.double(mu0), as.double(z0), as.integer(N), as.integer(jmax), ans=double(length=LL), PACKAGE="spc")$ans if (dtyp==1 & rando) { names(crit) <- c("AL", "AU", "gL", "gU") } else { if ( ctyp==0 ) names(crit) <- "AU" if ( ctyp==1 ) names(crit) <- "AL" if ( dtyp==0 ) names(crit) <- "A" if ( dtyp==1 ) names(crit) <- c("AL", "AU") } crit } spc/R/xtewma.q.R0000644000176200001440000000304313553640534013137 0ustar liggesusers# Computation of EWMA quantiles (mean monitoring, t distributed data) xtewma.q <- function(l, c, df, mu, alpha, zr=0, hs=0, sided="two", limits="fix", mode="tan", q=1, r=40) { if ( l <= 0 | l > 1 ) warning("l is typically between 0 and 1 -- you should really know what you do") if ( c<=0 ) warning("usually, c has to be positive") if ( df < 1 ) stop("df must be greater or equal to 1") if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)") if ( zr > c & sided == "one") stop("wrong reflexion border") if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) ) warning("unusual headstart") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl")) if (is.na(ltyp)) stop("invalid limits type") ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan")) if ( is.na(ntyp) ) stop("substitution type not provided (yet)") if ( r < 4 ) stop("r is too small") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") quant <- .C("xtewma_q", as.integer(ctyp), as.double(l), as.double(c), as.double(alpha), as.double(zr), as.double(hs), as.integer(df), as.double(mu), as.integer(ltyp), as.integer(r), as.integer(ntyp), as.integer(q), ans=double(length=1),PACKAGE="spc")$ans names(quant) <- "q" quant } spc/R/xcusum.arl.R0000644000176200001440000000160713553640534013500 0ustar liggesusers# Computation of CUSUM ARLs (mean monitoring) xcusum.arl <- function(k, h, mu, hs=0, sided="one", method="igl", q=1, r=30) { if (k<0) stop("k has to be non-negative") if (h<=0) stop("h has to be positive") if ( hs<0 | (sided=="two" & hs>h/2+k) | (sided=="one" & hs>h) ) stop("wrong headstart") if (r<4) stop("r is too small") ctyp <- pmatch(sided, c("one", "two", "Crosier")) - 1 if (is.na(ctyp)) stop("invalid cusum type") mtyp <- pmatch(method, c("igl", "mc", "mct", "mcl")) - 1 if (is.na(mtyp)) stop("invalid method") q <- round(q) if (q<1) stop("wrong change point position (q)") arl <- .C("xcusum_arl", as.integer(ctyp), as.double(k), as.double(h), as.double(hs), as.double(mu), as.integer(q), as.integer(r), as.integer(mtyp), ans=double(length=q), PACKAGE="spc")$ans names(arl) <- NULL return (arl) } spc/R/sewma.crit.R0000644000176200001440000000731113553640534013451 0ustar liggesusers# Computation of EWMA critical values for given ARL (variance monitoring) sewma.crit <- function(l, L0, df, sigma0=1, cl=NULL, cu=NULL, hs=NULL, s2.on=TRUE, sided="upper", mode="fixed", ur=4, r=40, qm=30) { mitte <- sqrt( 2/df ) * gamma( (df+1)/2 )/ gamma( df/2 ) if ( is.null(hs) ) { if ( s2.on ) { hs <- 1 } else { hs <- mitte } } cu0 <- cl0 <- 0 if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( L0<1 ) stop("L0 is too small") if ( df<1 ) stop("df must be positive") if ( sigma0<=0 ) stop("sigma0 must be positive") if ( sided=="Rupper" ) { if ( is.null(cl) ) stop("set cl") if ( cl<=0 ) stop("cl must be positive") cl0 <- cl if ( hs 1/L0 ) { cv <- c(0, Inf) warning("upper limit too small") } else { a1 <- 1/L0 - a2 cv <- c(qchisq(a1, df)/df, cu) } } if ( mode=="unbiased") { a1 <- 1/(2*L0) step <- 1/(2*L0)/10 one <- 1 for ( j in 1:8 ) { for ( i in 1:11 ) { a1 <- a1 + step*one k1 <- qchisq(a1, df) a2 <- 1/L0 - a1 k2 <- qchisq(1-a2, df) condition <- (k2 - k1)/(log(k2) - log(k1)) if ( (one*condition) > (one*df) ) break } step <- step/10 one <- -one if ( abs(condition - df) < 1e-10 ) break } cv <- c(k1, k2)/df } if ( mode=="eq.tails" ) { a <- 1/(2*L0) cv <- qchisq(c(a, 1-a), df)/df } if ( mode=="vanilla" ) { a <- 1/L0 k2 <- qchisq(1-a, df) k1 <- 2*df - k2 if ( k1 > 0 ) { zero <- function(x) ( pchisq( 2*df - qchisq(1-x, df), df) + x ) - 1/L0 a <- uniroot(zero, c(1/(2*L0), 1/L0), tol=1e-12)$root k2 <- qchisq(1-a, df) k1 <- 2*df - k2 cv <- c(k1, k2)/df } else { cv <- c(0, Inf) warning("symmetric design not possible") } } } } else { cv <- .C("sewma_crit",as.integer(ctyp),as.integer(ltyp),as.double(l), as.double(L0),as.double(cl0),as.double(cu0),as.double(hs), as.double(sigma0),as.integer(df),as.integer(r),as.integer(qm), as.double(ur),as.integer(s_squared), ans=double(length=2),PACKAGE="spc")$ans } names(cv) <- c("cl", "cu") cv } spc/R/mewma.arl.R0000644000176200001440000000250113553640534013254 0ustar liggesusers# Computation of MEWMA ARLs (multivariate mean monitoring) mewma.arl <- function(l, cE, p, delta=0, hs=0, r=20, ntype=NULL, qm0=20, qm1=qm0) { if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( cE<=0 ) stop("threshold c has to be positive") if ( p<1 ) stop("wrong dimension parameter") if ( delta<0 ) stop("wrong magnitude value") if ( hs<0 ) stop("wrong head start value") if ( r<4 ) stop("resolution too small") if ( qm0<5 ) stop("more quadrature nodes needed") if ( qm1<5 ) stop("more quadrature nodes needed") if ( is.null(ntype) ) { if ( delta <1e-10 ) { ntype <- "gl2" } else { #if ( p %in% c(2,4) ) { if ( p==2 ) { ntype <- "gl3" } else { ntype <- "gl5" } } } qtyp <- pmatch(tolower(ntype), c("gl", "co", "ra", "cc", "mc", "sr", "co2", "gl2", "gl3", "gl4", "gl5", "co3", "co4", "ngl1", "ngl2", "ngl3", "ngl4", "ngl5")) - 1 if ( is.na(qtyp) ) stop("invalid type of numerical algorithm") arl <- .C("mewma_arl", as.double(l), as.double(cE), as.integer(p), as.double(delta), as.double(hs), as.integer(r), as.integer(qtyp), as.integer(qm0), as.integer(qm1), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- NULL arl } spc/R/imr.arl.R0000644000176200001440000000335414252572675012753 0ustar liggesusers# Computation of I-MR ARLs imr.arl <- function(M, Ru, mu, sigma, vsided="upper", Rl=0, cmode="coll", N=30, qm=30) { if ( M <= 0 ) stop("M has to be positive") if ( Ru <= 0 ) stop("Ru has to be positive") if ( sigma <= 0 ) stop("sigma has to be positive") if ( Rl < 0 ) stop("Rl has to be non-negative") if ( N < 2 ) stop("N has to be >= 2") if ( qm < 10 ) stop("qm has to be >= 10") vsided <- tolower(vsided) cmode <- tolower(cmode) vtyp <- -1 + pmatch(vsided, c("upper", "two")) if ( Ru >= 2*M & vsided == "upper" ) { # initial solution, which works only in the in-control case #Lu <- 1 / ( 2*pnorm(-M, mean=mu, sd=sigma) ) #arl <- 1 + Lu * ( 2*pnorm(M, mean=mu, sd=sigma) - 1 ) # the complicated solution #Lu <- 1 / ( pnorm(-M, mean=mu, sd=sigma) + pnorm(-M, mean=-mu, sd=sigma) ) #arl <- 1 + Lu * ( pnorm(M, mean=mu, sd=sigma) - pnorm(-M, mean=mu, sd=sigma) ) # the 'elegant' approach arl <- 1 / ( pnorm(-M, mean=mu, sd=sigma) + pnorm(-M, mean=-mu, sd=sigma) ) } else { arl <- -1 if ( cmode == "coll" | vsided=="two" ) { arl <- .C("imr_arl", as.double(M), as.double(Rl), as.double(Ru), as.double(mu), as.double(sigma), as.integer(vtyp), as.integer(N), as.integer(qm), ans=double(length=1), PACKAGE="spc")$ans } if ( cmode == "crowder" ) { if ( vsided == "two" ) warning("confirmed only for upper MR") arl <- imr.arl.C1987b(M, Ru, mu, sigma, N=N) } if ( cmode %in% c("gl", "rectangular", "trapezoid", "simpson", "simpson3_8") ) { if ( vsided == "two" ) warning("confirmed only for upper MR") arl <- imr.arl.Ny(M, Ru, mu/sigma, N, kind=cmode) } } names(arl) <- "arl" arl } spc/R/xDcusum.arl.R0000644000176200001440000000200513553640534013575 0ustar liggesusers# 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/mewma.ad.R0000644000176200001440000000300213553640534013057 0ustar liggesusers# Computation of MEWMA steady-state ARLs (multivariate mean monitoring) mewma.ad <- function(l, cE, p, delta=0, r=20, n=20, type="cond", hs=0, ntype=NULL, qm0=20, qm1=qm0) { if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( cE<=0 ) stop("threshold c has to be positive") if ( p<1 ) stop("wrong dimension parameter") if ( delta<0 ) stop("wrong magnitude value") if ( r<4 ) stop("resolution too small") if ( n<5 ) stop("more quadrature nodes needed") itype <- pmatch(tolower(type), c("cond", "cycl")) - 1 if ( is.na(itype) ) stop("wrong type of steady-state density") if ( hs<0 ) stop("wrong head start value") if ( r<4 ) stop("resolution too small") if ( qm0<5 ) stop("more quadrature nodes needed") if ( qm1<5 ) stop("more quadrature nodes needed") if ( is.null(ntype) ) { if ( delta <1e-10 ) { ntype <- "gl2" } else { if ( p==2 ) { ntype <- "gl3" } else { ntype <- "gl5" } } } qtyp <- pmatch(tolower(ntype), c("gl", "co", "ra", "cc", "mc", "sr", "co2", "gl2", "gl3", "gl4", "gl5", "co3", "co4", "ngl1", "ngl2", "ngl3", "ngl4", "ngl5")) - 1 if ( is.na(qtyp) ) stop("invalid type of numerical algorithm") ad <- .C("mewma_ad", as.double(l), as.double(cE), as.integer(p), as.double(delta), as.integer(r), as.integer(n), as.integer(itype), double(hs), as.integer(qtyp), as.integer(qm0), as.integer(qm1), ans=double(length=1), PACKAGE="spc")$ans names(ad) <- NULL ad } spc/R/xewma.q.R0000644000176200001440000000265713553640534012765 0ustar liggesusers# Computation of EWMA quantiles (mean monitoring) xewma.q <- function(l, c, mu, alpha, zr=0, hs=0, sided="two", limits="fix", q=1, r=40) { if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1") if ( c<=0 ) warning("usually, c has to be positive") if ( alpha <= 0 | alpha >= 1) stop("quantile level alpha must be in (0,1)") if ( zr > c & sided == "one") stop("wrong reflexion border") if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) ) warning("unusual headstart") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat", "test")) if (is.na(ltyp)) stop("invalid limits type") if ( (sided=="one") & !( limits %in% c("fix", "vacl", "stat") ) ) stop("not supported for one-sided EWMA (not reasonable or not implemented yet") if ( r < 4 ) stop("r is too small") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") quant <- .C("xewma_q", as.integer(ctyp), as.double(l), as.double(c), as.double(alpha), as.double(zr), as.double(hs), as.double(mu), as.integer(ltyp), as.integer(r), as.integer(q), ans=double(length=1),PACKAGE="spc")$ans names(quant) <- "q" quant } spc/R/xewma.sf.R0000644000176200001440000000263013553640534013124 0ustar liggesusers# 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 )) ) warning("unusual headstart") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat", "test")) if (is.na(ltyp)) stop("invalid limits type") if ( (sided=="one") & !( limits %in% c("fix", "vacl", "stat") ) ) stop("not supported for one-sided EWMA (not reasonable or not implemented yet") if ( r < 4 ) stop("r is too small") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") sf <- .C("xewma_sf", as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.double(hs), as.double(mu), as.integer(ltyp), as.integer(r), as.integer(q), as.integer(n), ans=double(length=n),PACKAGE="spc")$ans names(sf) <- NULL sf } spc/R/xsewma.sf.R0000644000176200001440000000265313553640534013314 0ustar liggesusers# Computation of EWMA survival function (simultaneous mean & variance monitoring) xsewma.sf <- function(n, lx, cx, ls, csu, df, mu, sigma, hsx=0, Nx=40, csl=0, hss=1, Ns=40, sided="upper", qm=30) { if ( n < 1 ) stop("n has to be a natural number") if ( lx<=0 | lx>1 ) stop("lx has to be between 0 and 1") if ( ls<=0 | ls>1 ) stop("ls has to be between 0 and 1") if ( cx<=0 ) stop("cx has to be positive") if ( csu<=0 ) stop("csu has to be positive") if ( csl<0 ) stop("csl has to be non-negative") if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") if ( abs(hsx)>cx ) stop("wrong headstart hsx") if ( hsscsu ) stop("wrong headstart hss") if ( Nx<5 ) stop("Nx is too small") if ( Ns<10 ) stop("Ns is too small") if ( qm<5 ) stop("qm is too small") ctyp <- pmatch(sided, c("upper","Rupper","two","lower")) - 1 if (is.na(ctyp)) stop("invalid ewma type") sf <- .C("xsewma_sf", as.integer(ctyp), as.double(lx),as.double(cx),as.double(hsx),as.integer(Nx), as.double(ls),as.double(csl),as.double(csu),as.double(hss),as.integer(Ns), as.double(mu),as.double(sigma),as.integer(df),as.integer(qm), as.integer(n), ans=double(length=n),PACKAGE="spc")$ans names(sf) <- NULL sf } spc/R/mewma.psi.R0000644000176200001440000000243213553640534013274 0ustar liggesusers# Computation of MEWMA steady-state pdf (multivariate mean monitoring) mewma.psi <- function(l, cE, p, type="cond", hs=0, r=20) { if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( cE<=0 ) stop("threshold c has to be positive") if ( p<1 ) stop("wrong dimension parameter") if ( hs<0 ) stop("wrong head start value") if ( r<4 ) stop("resolution too small") itype <- pmatch(tolower(type), c("cond", "cycl")) - 1 if ( is.na(itype) ) stop("wrong type of steady-state density") zeug <- .C("mewma_psi", as.double(l), as.double(cE), as.integer(p), as.integer(itype), as.double(hs), as.integer(r), ans=double(length=3*r+1), PACKAGE="spc")$ans zahl <- zeug[1] PSI <- zeug[1:r + 1] w <- zeug[1:r + r+1] z <- zeug[1:r + 2*r+1] l2 <- ( (1-l)/l )^2 fchi <- function(u, a) 2*a * dchisq( u^2/l^2, p, ncp=l2*a^2)/l^2 if ( itype == 0 ) psi <- Vectorize(function(x) sum( w * PSI * fchi(sqrt(x), z))/zahl, "x") if ( itype == 1 ) { if ( hs < 1e-9 ) psi <- Vectorize(function(x) dchisq( x/l^2, p)/l^2 / zahl + sum( w * PSI * fchi(sqrt(x), z) ), "x") if ( hs >= 1e-9 ) psi <- Vectorize(function(x) fchi(sqrt(x), hs) / zahl + sum( w * PSI * fchi(sqrt(x), z) ), "x") } psi }spc/R/xewma.arl.prerun.R0000644000176200001440000000346713553640534014615 0ustar liggesusers# Computation of EWMA ARLs (mean monitoring) under specified pr-run scenarios xewma.arl.prerun <- function(l, c, mu, zr=0, hs=0, sided="two", limits="fix", q=1, size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10) { if ( l<=0 | l>1 ) stop("l has to be between 0 and 1") if ( c<=0 ) warning("usually, c has to be positive") if ( zr>c & sided=="one" ) stop("wrong reflexion border") if ( (sided=="two" & abs(hs)>c) | (sided=="one" & (hsc)) ) warning("unusual headstart") ctyp <- pmatch(sided, c("one", "two")) - 1 if (is.na(ctyp)) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat")) if (is.na(ltyp)) stop("invalid limits type") if ( (sided=="one") & !(limits %in% c("fix", "vacl", "stat", "limit", "fixW")) ) stop("not supported for one-sided EWMA (not reasonable or not implemented yet") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") if ( size<2 ) stop("pre run size too small") if ( is.null(df) ) df = size - 1 if ( df<1 ) stop("degrees of freedom (df) too small") emode <- -1 + pmatch(estimated, c("mu", "sigma", "both")) if (is.na(emode)) stop("invalid to be estimated type") if ( qm.mu<4 ) stop("qm.mu is too small") if ( qm.sigma<4 ) stop("qm.sigma is too small") if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") arl <- .C("xewma_arl_prerun", as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.double(hs), as.double(mu), as.integer(ltyp), as.integer(q), as.integer(size), as.integer(df), as.integer(emode), as.integer(qm.mu), as.integer(qm.sigma), as.double(truncate), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- "arl" return (arl) } spc/R/imr.Rl_Mgiven.R0000644000176200001440000000040614017233532014033 0ustar liggesusersimr.Rl_Mgiven <- function(M, L0, N=30, qm=30) { M0 <- qnorm( 1-1/(2*L0) ) if ( M > M0 ) { zero <- function(x) imr.arl(M, 3*M, 0, 1, vsided="two", Rl=x, N=N, qm=qm) - L0 Rl <- uniroot(zero, c(1e-6, 1), tol=1e-9)$root } else { Rl <- 0 } Rl } spc/R/scusums.arl.R0000644000176200001440000000255113553640534013655 0ustar liggesusers# Computation of CUSUM-Shewhart ARLs (variance monitoring) scusums.arl <- function(k, h, cS, sigma, df, hs=0, sided="upper", k2=NULL, h2=NULL, hs2=0, r=40, qm=30, version=2) { if ( k<0 ) stop("k has to be non-negative") if ( h<=0 ) stop("h has to be positive") if ( cS<=0 ) stop("cS has to be positive") if ( hs<0 | hs>h ) stop("wrong headstart") if ( sided=="two" ) { if ( is.null(k2) | is.null(h2) ) stop("in case of a two-sided CUSUM scheme one has to define two sets of (k,h,hs)") if ( k2<0 ) stop("k2 has to be non-negative") if ( h2<=0 ) stop("h2 has to be positive") if ( hs2<0 | hs2>h2 ) stop("wrong headstart") } if ( sigma<=0 ) stop("sigma must be positive") if ( df<1 ) stop("df must be larger than or equal to 1") ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1 if ( is.na(ctyp) ) stop("invalid cusum type") if ( r<10 ) stop("r is too small") if ( qm<10 ) stop("qm is too small") arl <- .C("scusum_s_arl", as.integer(ctyp), as.double(k), as.double(h), as.double(hs), as.double(cS), as.double(sigma), as.integer(df), as.double(k2), as.double(h2), as.double(hs2), as.integer(r), as.integer(qm), as.integer(version), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- "arl" arl } spc/R/xtewma.arl.R0000644000176200001440000000315313553640534013457 0ustar liggesusers# Computation of EWMA ARLs (mean monitoring, t distributed data) xtewma.arl <- function(l, c, df, mu, zr=0, hs=0, sided="two", limits="fix", mode="tan", q=1, r=40) { if ( l<=0 || l>1 ) warning("l is typically between 0 and 1 -- you should really know what you do") if ( c<=0 ) warning("usually, c has to be positive") if ( df < 1 ) stop("df must be greater or equal to 1") if ( zr>c & sided=="one" ) stop("wrong reflexion border") if ( (sided=="two" & abs(hs)>c) | (sided=="one" & (hsc)) ) warning("unusual headstart") if ( r<4 ) stop("r is too small") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl")) if ( is.na(ltyp) ) stop("invalid limits type") ntyp <- -1 + pmatch(mode, c("identity", "sin", "sinh", "tan")) if ( is.na(ntyp) ) stop("substitution type not provided (yet)") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") if ( limits=="fix" & q>1 ) { arl <- .C("xtewma_arl",as.integer(ctyp),as.double(l), as.double(c),as.double(zr),as.double(hs),as.integer(df), as.double(mu),as.integer(ltyp),as.integer(r),as.integer(ntyp),as.integer(q), ans=double(length=q), PACKAGE="spc")$ans } else { arl <- .C("xtewma_arl",as.integer(ctyp),as.double(l), as.double(c),as.double(zr),as.double(hs),as.integer(df), as.double(mu),as.integer(ltyp),as.integer(r),as.integer(ntyp),as.integer(q), ans=double(length=1), PACKAGE="spc")$ans } names(arl) <- NULL return (arl) } spc/R/xewma.q.crit.prerun.R0000644000176200001440000000574113553640534015234 0ustar liggesusersxewma.q.crit.prerun <- function(l, L0, mu, p, zr=0, hs=0, sided="two", limits="fix", size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, bound=1e-10, c.error=1e-10, p.error=1e-9, OUTPUT=FALSE) { if ( OUTPUT ) cat("\nc\t\tp\n") c2 <- xewma.q.crit(l, L0, mu, p, zr=zr, hs=hs, sided=sided, limits=limits, OUTPUT=FALSE) p2 <- 1 - xewma.sf.prerun(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) if ( p2 > p ) { while ( p2 > p ) { p1 <- p2 c2 <- c2 + .5 p2 <- 1 - xewma.sf.prerun(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } c1 <- c2 - .5 } else { while ( p2 <= p ) { p1 <- p2 c2 <- c2 - .5 p2 <- 1 - xewma.sf.prerun(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } c1 <- c2 + .5 } if ( size < 41 ) { if ( qm.mu < 70 ) qm.mu <- 70 if ( qm.mu < 70 ) qm.mu <- 70 if ( size < 21 ) { if ( qm.mu < 90 ) qm.mu <- 90 if ( qm.mu < 90 ) qm.mu <- 90 } if ( p2 > p ) { while ( p2 > p ) { p1 <- p2 c2 <- c2 + .1 p2 <- 1 - xewma.sf.prerun(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } c1 <- c2 - .1 } else { while ( p2 <= p ) { p1 <- p2 c2 <- c2 - .1 p2 <- 1 - xewma.sf.prerun(l, c2, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0] if ( OUTPUT ) cat(paste(c2,"\t",p2,"\n")) } c1 <- c2 + .1 } } p.error_ <- 1; c.error_ <- 1 while ( p.error_ > p.error & c.error_ > c.error ) { c3 <- c1 + (p - p1)/(p2 - p1)*(c2 - c1) p3 <- 1 - xewma.sf.prerun(l, c3, mu, L0, zr=zr, hs=hs, sided=sided, limits=limits, q=1, size=size, df=df, estimated=estimated, qm.mu=qm.mu, qm.sigma=qm.sigma, truncate=truncate, bound=bound)[L0] if ( OUTPUT ) cat(paste(c3,"\t",p3,"\n")) c1 <- c2; c2 <- c3 p1 <- p2; p2 <- p3 p.error_ <- abs(p2 - p); c.error_ <- abs(c2 - c1) } names(c3) <- "c" c3 } spc/R/euklid.ewma.arl.R0000644000176200001440000000155213553640534014360 0ustar liggesusers# Computation of 'Euklid'-EWMA ARLs for iid Poisson (Rakitzis/Castagliola/Maravelakis 2015) euklid.ewma.arl <- function(gX, gY, kL, kU, mu, y0, r0=0) { if ( gX <= 0 ) stop("gX must be positive") if ( gY <= 0 ) stop("gY must be positive") if ( kL <= 0 ) stop("kL must be positive") if ( kU <= 0 ) stop("kU must be positive") if ( kU < kL ) stop("kU must be larger than or equal to kL") if ( mu <= 0 ) stop("mu must be positive") if ( y0 <= 0 ) stop("y0 must be positive") if ( r0 < 0 ) stop("r0 must be non-negative") arl <- .C("euklid_ewma_arl", as.integer(gX), as.integer(gY), as.integer(kL), as.integer(kU), as.double(mu), as.double(y0), as.integer(r0), ans=double(length=1), PACKAGE="spc")$ans names(arl) <- "arl" arl } spc/R/xDewma.arl.R0000644000176200001440000000246613553640534013405 0ustar liggesusers# 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/qphat.R0000644000176200001440000000154213553640534012512 0ustar liggesusersqphat <- function(p, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30) { if ( n < 1 ) stop("n must be >= 1") if ( sigma<1e-10 ) stop("sigma much too small") ctyp <- -1 + pmatch(type, c("known", "estimated")) if ( is.na(ctyp) ) stop("invalid sigma mode") if ( LSL >= USL ) stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)") if ( nodes<2 ) stop("far too less nodes") qf <- rep(NA, length(p)) for ( i in 1:length(p) ) { qf[i] <- NA if ( 0 g ) stop("wrong headstart") hs <- hs } else { hs <- 11*g # mimics -infinity #hs <- inf } q <- round(q) if ( q < 1 ) stop("wrong change point position (q)") if ( r < 4 ) stop("r is too small") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid grsr type") arl <- .C("xgrsr_arl", as.integer(ctyp), as.double(k), as.double(g), as.double(zr), as.double(hs), as.double(mu), as.integer(q), as.integer(r), as.integer(MPT), ans=double(length=q), PACKAGE="spc")$ans names(arl) <- NULL return (arl) } spc/R/xsewma.arl.R0000644000176200001440000000277213553640534013464 0ustar liggesusers# 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/dphat.R0000644000176200001440000000172113553640534012474 0ustar liggesusersdphat <- function(x, n, mu=0, sigma=1, type="known", LSL=-3, USL=3, nodes=30) { if ( n < 1 ) stop("n must be >= 1") if ( sigma<1e-10 ) stop("sigma much too small") ctyp <- -1 + pmatch(type, c("known", "estimated")) if ( is.na(ctyp) ) stop("invalid sigma mode") if ( LSL >= USL ) stop("wrong relationship between lower and upper specification limits (LSL must be smaller than USL)") if ( nodes<2 ) stop("far too less nodes") p.star <- pnorm( LSL/sigma ) + pnorm( -USL/sigma ) if ( type == "estimated" ) p.star <- 0 pdf <- rep(NA, length(x)) for ( i in 1:length(x) ) { pdf[i] <- 0 if ( p.star1 ) stop("l has to be between 0 and 2") if ( c<=0 ) warning("usually, c has to be positive") if ( zr>c & sided=="one" ) stop("wrong reflexion border") if ( 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") LENGTH <- 3*r zeug <- .C("xewma_arl_f", as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.double(mu), as.integer(ltyp), as.integer(r), ans=double(length=LENGTH), PACKAGE="spc")$ans g <- zeug[1:r] w <- zeug[1:r + r] z <- zeug[1:r + 2*r] arl <- Vectorize( function(x) 1 + sum( w * dnorm( ( z - (1-l)*x ) / l - mu)/l * g ) ) arl } spc/R/pois.ewma.ad.R0000644000176200001440000000237513651355201013660 0ustar liggesusers# Computation of Poisson EWMA steady-state ARLs pois.ewma.ad <- function(lambda, AL, AU, mu0, mu, sided="two", rando=FALSE, gL=0, gU=0, mcdesign="classic", N=101) { if ( lambda <= 0 | lambda > 1 ) stop("lambda has to be between 0 and 1") if ( AL < 0 | AU < 0 ) stop("control limit factors must be positive") if ( mu0 < 0 ) stop("wrong value for mu0") if ( mu < 0 ) stop("wrong value for mu") hL <- mu0 - AL*sqrt(lambda*mu0/(2-lambda)) hU <- mu0 + AU*sqrt(lambda*mu0/(2-lambda)) ctyp <- pmatch(sided, c("upper", "lower", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") mcd <- pmatch(mcdesign, c("classic", "transfer")) - 1 if ( is.na(mcd) ) stop("invalid mcdesign value") if ( rando ) { if ( gL < 0 | gL > 1 ) stop("wrong value for gL") if ( gU < 0 | gU > 1 ) stop("wrong value for gU") } ad <- .C("cewma_ad_be", as.integer(ctyp), as.integer(mcd), as.integer(rando), as.double(lambda), as.double(AL), as.double(AU), as.double(gL), as.double(gU), as.double(mu0), as.double(mu), as.integer(N), ans=double(length=1), PACKAGE="spc")$ans names(ad) <- "ad" ad } spc/R/xewma.sf.prerun.R0000644000176200001440000000441013553640534014434 0ustar liggesusers# Computation of EWMA survival function (mean monitoring) under specified pre-run scenarios xewma.sf.prerun <- function(l, c, mu, n, zr=0, hs=0, sided="one", limits="fix", q=1, size=100, df=NULL, estimated="mu", qm.mu=30, qm.sigma=30, truncate=1e-10, tail_approx=TRUE, bound=1e-10) { if ( l <= 0 | l > 1 ) stop("l (lambda) has to be between 0 and 1") if ( c <= 0 ) warning("usually, c has to be positive") if ( n < 1 ) stop("n has to be a natural number") if ( zr > c & sided == "one") stop("wrong reflexion border") if ( (sided == "two" & abs(hs) > c) | (sided == "one" & ( hs < zr | hs > c )) ) stop("wrong headstart") ctyp <- pmatch(sided, c("one", "two")) - 1 if ( is.na(ctyp) ) stop("invalid ewma type") ltyp <- -1 + pmatch(limits, c("fix", "vacl", "fir", "both", "Steiner", "stat")) if (is.na(ltyp)) stop("invalid limits type") if ( (sided=="one") & !( limits %in% c("fix", "vacl", "stat") ) ) stop("not supported for one-sided EWMA (not reasonable or not implemented yet") q <- round(q) if ( q<1 ) stop("wrong change point position (q)") if ( size<2 ) stop("pre run size too small") if ( is.null(df) ) df = size - 1 if ( df<1 ) stop("degrees of freedom (df) too small") emode <- -1 + pmatch(estimated, c("mu", "sigma", "both")) if (is.na(emode)) stop("invalid to be estimated type") if ( qm.mu<4 ) stop("qm.mu is too small") if ( qm.sigma<4 ) stop("qm.sigma is too small") if ( truncate < 0 | truncate >= 0.5 ) stop("wrong value for truncate (should follow 0 < truncate < 0.5)") if ( bound < 0 | bound >= 0.001 ) stop("wrong value for bound (should follow 0 < truncate < 0.001)") sf <- .C("xewma_sf_prerun", as.integer(ctyp), as.double(l), as.double(c), as.double(zr), as.double(hs), as.double(mu), as.integer(ltyp), as.integer(q), as.integer(n), as.integer(size), as.integer(df), as.integer(emode), as.integer(qm.mu), as.integer(qm.sigma), as.double(truncate), as.integer(tail_approx), as.double(bound), ans=double(length=n),PACKAGE="spc")$ans names(sf) <- NULL sf }spc/R/imr.RuRl_alone_tail.R0000644000176200001440000000127414017164744015240 0ustar liggesusersimr.RuRl_alone_tail <- function(L0, N=30, qm=30, M0=12) { zero <- Vectorize(function(x) { alpha <- 4 * (1 - pnorm(x/sqrt(2)) ) Rl <- sqrt(2) * qnorm(0.5+alpha/4) imr.arl(M0, x, 0, 1, vsided="two", Rl=Rl, N=N, qm=qm) - L0 }) Ru1 <- sqrt(2) * qnorm( 1-1/(4*L0) ) D1 <- zero(Ru1) if ( D1 < 0 ) { while ( D1 < 0 ) { Ru2 <- Ru1 Ru1 <- Ru1 * 1.1 D1 <- zero(Ru1) } D1 <- Ru1 Ru1 <- Ru2 Ru2 <- D1 } else { while ( D1 > 0 ) { Ru2 <- Ru1 Ru1 <- Ru1 / 1.1 D1 <- zero(Ru1) } } Ru <- uniroot(zero, c(Ru1, Ru2), tol=1e-9)$root alpha <- 4 * (1 - pnorm(Ru/sqrt(2)) ) Rl <- sqrt(2) * qnorm(0.5+alpha/4) c(Rl, Ru) } spc/R/imr.Rl_Rugiven.R0000644000176200001440000000077614017164633014244 0ustar liggesusersimr.Rl_Rugiven <- function(Ru, L0, N=30, qm=30, M0=12) { zero <- function(x) imr.arl(M0, Ru, 0, 1, vsided="two", Rl=x, N=N, qm=qm) - L0 Rl1 <- sqrt(2) * qnorm(0.5+1/(4*L0)) z1 <- zero(Rl1) if ( z1 < 0 ) { while ( z1 < 0 ) { Rl2 <- Rl1 Rl1 <- Rl1 / 1.1 z1 <- zero(Rl1) } z1 <- Rl1 Rl1 <- Rl2 Rl2 <- z1 } else { while ( z1 > 0 ) { Rl2 <- Rl1 Rl1 <- Rl1 * 1.1 z1 <- zero(Rl1) } } Rl <- uniroot(zero, c(Rl1, Rl2), tol=1e-9)$root Rl } spc/MD50000644000176200001440000003062114325502512011350 0ustar liggesusers5ac3acd8be3e0c91c6d3de8d4ead7096 *DESCRIPTION 1c31ccc48b322affe4d83548723b8d6b *NAMESPACE 938e63b937546368d2a3ad73dbc1a749 *R/dphat.R a794896e1669243395c72444bff75161 *R/euklid.ewma.arl.R 63fa23d01b1d1406e4a658823230cabb *R/imr.MandRu.R 6c01cffb9e13d01e216c2f62094c5503 *R/imr.MandRuRl.R d8a2f11a75847f4e9d034c99e591963d *R/imr.Rl_Mgiven.R e88248f3716ed01bba54b72d5f5873bc *R/imr.Rl_Rugiven.R d39f294217997517b4bd4d5603295a06 *R/imr.RuRl_alone.R d5e45588b0eec071148da20288a4a117 *R/imr.RuRl_alone_s3.R 97917cdc6847d428fc81072561ee9d3f *R/imr.RuRl_alone_tail.R 701618bc929388eb6c3cc01b24bb5552 *R/imr.Ru_Mgiven.R c18f45c7b5b1e91913d63974adc64024 *R/imr.Ru_Rlgiven.R ef3aa55a5db94a9f4210fd68a0d93a3a *R/imr.arl.C1987b.R b9789db921781461f63d3f51b841f34d *R/imr.arl.Ny.R c4a742446ab481048b67a5cbf3f0cd47 *R/imr.arl.R 46823b56986ca3813c49e4fc8eb421eb *R/lns2ewma.arl.R 0e2143506950183c7381613da155171f *R/lns2ewma.crit.R 746a7e799163c0af0a01bb418655531e *R/mewma.ad.R 49bb150301a19e51c7fe5a8c5124a8fc *R/mewma.arl.R f505941b925a9a1de39ea97dbd6d3373 *R/mewma.arl.f.R e68659aaacd0fe568034de97d3ced575 *R/mewma.crit.R d635b9dbb2f078b5fd208327b7f9d678 *R/mewma.psi.R 24007c2ea061064d4369eac257acbc33 *R/p.ewma.arl.R e9cfc122ce8e168cc01df062d400d6bf *R/phat.ewma.arl.R a65306a9a11b5e3dac9128f086615469 *R/phat.ewma.crit.R cde50d6572735dec15253ac814d1294b *R/phat.ewma.lambda.R 9b71bc5d60bf0458dea4f8ce4c7c4253 *R/pois.cusum.arl.R b9f28e220769a0c9fa13ed5a68687fe7 *R/pois.cusum.crit.L0L1.R dc876f2fb0a968778a8fd54df31a5e6d *R/pois.cusum.crit.R fcfa29faa7aa63fbe7d9576f4c0484d8 *R/pois.ewma.ad.R 0fd0980aee8dde8e2ed120e7502ff2d4 *R/pois.ewma.arl.R 85d621f4c0f8f1e2a959023f73e13df2 *R/pois.ewma.crit.R 8493c6ffe635deab1f9b9120b14e7330 *R/pphat.R 76dbd6c5db0fb64dfe91f76b9aab6312 *R/qphat.R 85f5c1605413c07024e732ffc33fb789 *R/quadrature.nodes.weights.R 317e34aaffbe5a167d6f84b92b225dc1 *R/s.res.ewma.arl.R fcca944c36e65ab9046977f17f0cd706 *R/scusum.arl.R c738ce11a5abce3a5756649839160bd5 *R/scusum.crit.R ba1cf773ae89b318fdede34ae0f65809 *R/scusums.arl.R 2acc113d9f2281a5ef782528fd90df65 *R/sewma.arl.R f0409e488a90344e564cb55f89445e74 *R/sewma.arl.prerun.R 24accc353555015ac287d981cc932e77 *R/sewma.crit.R c5bcbcb0cd59edcaed4670bea5008eb1 *R/sewma.crit.prerun.R b49219549f661cd0ec55ecbfa905bb93 *R/sewma.q.R 8350a1a84ae6212b6b25fb45475acaae *R/sewma.q.crit.R e526b39efbc216bba1632d9b83ab8522 *R/sewma.q.crit.prerun.R db8fbd6c63492a8a5ae16732e32d95f3 *R/sewma.q.prerun.R 2d6e3631fff009282f8df33565f3c7d8 *R/sewma.sf.R 83d34c77f784b344f4dd063e0f487500 *R/sewma.sf.prerun.R 708b91d3e4d60a62fb05aac59ba59be6 *R/tewma.arl.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 01440bd5645f16e19cef8cc5f1b6abd9 *R/xcusum.arl.R 3ece9667f05deb05a7ecf3bff05bec59 *R/xcusum.crit.L0L1.R 159d295a0d1998df9504da0a0a820fde *R/xcusum.crit.L0h.R dc00420d8558cd9aa8a72799d57792ec *R/xcusum.crit.R f402ec38d884f261dc9ba5b74716d8ac *R/xcusum.q.R 185c396ccf056bd67841612b7db5c376 *R/xcusum.sf.R 35ee63dccee47665a0f6ec3b58a56fe4 *R/xewma.ad.R 9af41803763670519d91198535a2a1c3 *R/xewma.arl.R 5c7111218c951875c5751e6a4c293df4 *R/xewma.arl.f.R 2384b100e60076bede8e4d667fbe29b9 *R/xewma.arl.prerun.R bcf9da17e5c79decfc7fe43c321cec0a *R/xewma.crit.R 6eddc14fa12e5345561913a549b852f3 *R/xewma.crit.prerun.R cf4addd85eec5780753b88bd9e2af27d *R/xewma.q.R f5c770a08813cb160003470d1808f8ad *R/xewma.q.crit.R f6a968ae9d298c40c5585b00db74b8f3 *R/xewma.q.crit.prerun.R 5738bac113bb0816739ea94fc33491c5 *R/xewma.q.prerun.R 63bc340f0e5f72bd03910aac54b87dc8 *R/xewma.sf.R b84367be01626eb8912c9fb3cf3aa12b *R/xewma.sf.prerun.R 3266bb62646ca179fbda8b5d98e155f6 *R/xgrsr.ad.R 67bc1cedce86beb0c139c027eebadcb8 *R/xgrsr.arl.R ff71e4117307ee60de84ba58bbec0b7a *R/xgrsr.crit.R 30199f064e29b335f1cf70fb054d148b *R/xs.res.ewma.arl.R 48049b56879a2d94d06d60ad44a2f440 *R/xs.res.ewma.pms.R 3bd74fbfc2191fedce471f23d056bb17 *R/xsewma.arl.R 7555235086a9b36f11505121fcb4d223 *R/xsewma.crit.R 97b870b8e3fb5ee15acaba3236f6c7c8 *R/xsewma.q.R bdc534ec6379c94bcf559f279d14e49f *R/xsewma.q.crit.R f35fe332fd717ed54d72ee9c7b69b015 *R/xsewma.sf.R b9faf08ba81def9017f9ae184c03a9c8 *R/xshewhart.ar1.arl.R 24bbe9df9f8a6abe6c497ed01a17d397 *R/xshewhartrunsrules.ad.R 4facffeca81aa3f9ac0f2b9e8089902d *R/xshewhartrunsrules.arl.R 6301fa5dedf8ba0804e7a03914836094 *R/xshewhartrunsrules.crit.R 886226d03f84cfbcef6d779d76df6c1b *R/xshewhartrunsrules.matrix.R e3adc64172316afd9a2ad78b611cb797 *R/xtcusum.arl.R b342f3113b2c398924824e5c15c0162a *R/xtewma.ad.R 3271e757c33e48d87e87f773ad9f6364 *R/xtewma.arl.R ed29d98eef38e0ae9c70d81016ef3a4b *R/xtewma.q.R 456f24087f1d58b0bee856fe348ec065 *R/xtewma.q.crit.R a4f288e5b90e0ad70393a46f64c89695 *R/xtewma.sf.R 27f5d1c16f5223dedff8cb312414bc92 *R/xtshewhart.ar1.arl.R 08424d9ece6e6b1be221fdda65e878d0 *man/dphat.Rd c75877f64b5297c35a4f6e43fd24b24b *man/euklid.ewma.arl.Rd b84f50b0c3bc6f46e16dc9b4b68f2eb9 *man/imr.RuRl_alone.Rd 5d277b6ae3042a4b93e56755d4bca54d *man/imr.arl.Rd d50a13c09994b01089ea76669c609346 *man/lns2ewma.crit.Rd 88c66319a2af8f03cd10de612085d4cd *man/lns2sewma.arl.Rd 0f71afb1363721ecee3feb02bbe230b5 *man/mewma.arl.Rd 2dabf5d28f4399b5af60a4f54979e617 *man/mewma.crit.Rd a77a8fefe5e96f6546c18ef78fd0e8bc *man/mewma.psi.Rd 0cdb8394ef6b2c6d64d5c641d9edf1cb *man/p.ewma.arl.Rd 7bdda3d7ac509853fab1dc68a1e99ba3 *man/phat.ewma.arl.Rd 7affda30afc5b9f13675788487f198f4 *man/pois.crit.L0L1.Rd a68f5059fe3cce9b8b08974ae1102c8c *man/pois.cusum.arl.Rd 406c02a17f01d98cd9fca7a8d64fa2ef *man/pois.cusum.crit.Rd a5827c7b4936c8e3c7cad6124116e484 *man/pois.ewma.ad.Rd 9469df22aa04c65a319b8c126861081e *man/pois.ewma.arl.Rd e59fa07d0824736ddbab19f6ab8d386a *man/pois.ewma.crit.Rd 0b6e47e3e504f024e2c9eb52c67cd766 *man/quadrature.nodes.weights.Rd 0d471bf118ec7405bbdc4fd8106c70c9 *man/scusum.arl.Rd 686d334f1eeb578afbdeb7f56ccb9249 *man/scusum.crit.Rd 641da88e7baa05d5b91561da80b35add *man/scusums.arl.Rd 015f2d7adf1b312393a1deff41b82f0b *man/sewma.arl.Rd caa766da14afc017c5a2e577f7486f6d *man/sewma.arl.prerun.Rd 6b79d31a43f78798b0b9a973afddaf63 *man/sewma.crit.Rd 109ea0c794a646b6be88eb5a5b00777b *man/sewma.crit.prerun.Rd 03362fb7cbfd5e0203dcc221e06a263c *man/sewma.q.Rd 57fc3ea96be0260cb51c6b730962f297 *man/sewma.q.prerun.Rd a4226cd07f26c7a26098cb176038fbf4 *man/sewma.sf.Rd fd4b92b8ba7d607b83e382c84227b033 *man/sewma.sf.prerun.Rd 9a51dcc55b5a2c5f0fbda11138a9cf8f *man/tewma.arl.Rd 7640f6bb7702bfb6c0bae1cfe1118a63 *man/tol.lim.fact.Rd e06f37c1ade9acc3a5ed5765775df56a *man/xDcusum.arl.Rd 59f2f599371c9489d68d9f31a0e343b6 *man/xDewma.arl.Rd 6ffba75547def5cb7dc49d23b0bdc617 *man/xDgrsr.arl.Rd e3a1ea345ab1806c88b68f4ac70e9d82 *man/xDshewhartrunsrules.arl.Rd c6364ba0d27305c53a5f9726e21cb9ba *man/xcusum.ad.Rd f30a60c08e26007cf6d6d1922932ca4b *man/xcusum.arl.Rd 5628878c49afd037b1a17fdbd56620a8 *man/xcusum.crit.L0L1.Rd 7833ee5a4777ec8c983e416db55aa11a *man/xcusum.crit.L0h.Rd f35459613a412ea993676ce3a6ead850 *man/xcusum.crit.Rd e5459a7bf1a11e07e20e1e2635092c07 *man/xcusum.q.Rd 08f2cec21bdf235a8c7ffb5981930203 *man/xcusum.sf.Rd 83634f693c886eda98a4a13f259e9822 *man/xewma.ad.Rd c593e06f85f0ba84e3fa572118f922c9 *man/xewma.arl.Rd 64f7ba69cd8378fa95ef5bccba2c1414 *man/xewma.arl.f.Rd ea602bd2f4981650e51ddd94074b8f81 *man/xewma.arl.prerun.Rd b4138765aae313c0febf5058939bb9d8 *man/xewma.crit.Rd be8df35806ecfa4d0f4e179a1198905d *man/xewma.q.Rd b2c99083aa297992cd4c79692e3865ea *man/xewma.q.prerun.Rd 81c4afc665901d85eee2116bed7edd53 *man/xewma.sf.Rd 3f432ef08d8578afed11119d5bd9eb53 *man/xewma.sf.prerun.Rd 7c1c2e57c40e68820004d82a2fcad405 *man/xgrsr.ad.Rd 3d2057b862920530a53f0b19f0b54462 *man/xgrsr.arl.Rd 65b0074e43108c025e6f4164afa4c23b *man/xgrsr.crit.Rd 7a9b9c5f142ac513e3ca0f1a9d9474cf *man/xsewma.arl.Rd cc442af0a42b56cd24b45c6f8fe1c3e7 *man/xsewma.crit.Rd f8f9e59069615ea7fe37931dc0ff79b5 *man/xsewma.q.Rd e8f4c378e162f33b58f1290b74c267d5 *man/xsewma.sf.Rd ddc295897167c26fcd8efd58cd6d6875 *man/xshewhart.ar1.arl.Rd c4a5ce003421597f181f44fded11fe3e *man/xshewhartrunsrules.arl.Rd 590dffc5dfd1d2cafa16d816ce1c913c *man/xsresewma.arl.Rd a6ed29f1da028de10edce1926c8773a7 *man/xtcusum.arl.Rd 23e1abd7d33a2a0600b67190d5fa4068 *man/xtewma.ad.Rd a0761716e88359aaced32bc28b90f70c *man/xtewma.arl.Rd 394e66d297405c8be74ecb9803bea1a8 *man/xtewma.q.Rd ff3072d7d7328bec15ae828ba355df3d *man/xtewma.sf.Rd 2473c0960a56af19d8f417ce4fe9eb98 *man/xtshewhart.ar1.arl.Rd 2a6f9e9e044a78154d3cfda5936d6f48 *src/Makevars 8d17f2ea1a3188d3c2d5c63bc5e61ef4 *src/allspc.c e6acfcdb0acd56c9476000d0c538486b *src/ccusum_arl_be.c 1ef607ffc93eb93a13d3a6c166cc0e9c *src/ccusum_crit_be.c 669db61a1b0c2ccabcbc19f235f809b8 *src/cewma_ad_be.c 4bbe896e4efd81a019dc82bf19655064 *src/cewma_arl_be.c ddf3f313f099b55042c223311aea49f4 *src/cewma_crit_be.c 8525af4609163c65dc141383c5c5ad55 *src/euklid_ewma_arl.c 924d6277d6a13466ccf8de90faf3204b *src/ewma_p_arl_be.c 13a4e7af8e9d8ae22430511758649191 *src/ewma_phat_arl_coll.c e05ec9bd7cc1f2fd026b563a2e430edb *src/ewma_phat_crit_coll.c 30d2f093b1f54044ea0899dda2f1bd36 *src/ewma_phat_lambda_coll.c 3e9aeb3df3044477e4ce2ee8d0611505 *src/imr_arl.c 75d7d4568b9a704e70851104f1247547 *src/lns2ewma_arl.c cdec3fd6820823e934b178111270db95 *src/lns2ewma_crit.c f4d142b8518318a2e364efdae9e2c11a *src/mewma_ad.c cd5d0c9ee31baeeaa9585c294c47c385 *src/mewma_arl.c fcd694fdd18e2f91e1b550c4ee2bd2e0 *src/mewma_arl_f.c e055bc9dc17c7f2e40dcdf45e2dc05b6 *src/mewma_crit.c 4b3ca88dfd78cb7856e9322fe19ada66 *src/mewma_psi.c a343f3f97264c33987e3b423a0520782 *src/phat_cdf.c f98c7e364dd47f9e7a63bb27c484ce83 *src/phat_pdf.c 3cf82dbe65d6accc2443aa9cfd28c5fa *src/phat_qf.c 78d94b0dd1f7e7721c825665080cd93b *src/quadrature_nodes_weights.c 1138bbdb1fb193171d577c20cb8bb54b *src/scusum_arl.c 7043fc65d170cec221f04e13ae36914c *src/scusum_crit.c 29a4bc6d51d8f818b37490b85bd5b9ca *src/scusum_s_arl.c f2ff01ced990ba425fd4e712f65012bc *src/sewma_arl.c 4c920acf8afa10f0d6bde407839da097 *src/sewma_arl_prerun.c 1f605b968f10a42f77293c407a09dbe0 *src/sewma_crit.c d6da86484517aebe4dd0d4dabb4deaaf *src/sewma_crit_prerun.c 548c06b8ece5ee78db8a79efb6d9b6d0 *src/sewma_q.c 95bde8f159dcff0f056bb59fd0d3d6e8 *src/sewma_q_crit.c ee07b1626cb4f42144ffcfc29ff3ca39 *src/sewma_q_crit_prerun.c 8c01dd8052ec29bb2b8bc0a144c7aed4 *src/sewma_q_prerun.c dfa00954609e5b3a509a286ed48501e3 *src/sewma_res_arl.c ecf78a7adca417976353fd6cd0b1f297 *src/sewma_sf.c df8e9c91ce841335e4538292f8510f50 *src/sewma_sf_prerun.c a39976452102e4467dfaff39aedaee9a *src/spc_init.c 0e076161ec39bcafc09d16ec7085f6ce *src/tewma_arl_wowR.c 7d5d3b5fb77da4bc0112145513e70b07 *src/tol_lim_fac.c 2c0242acb16834c65e2b2af668d193c8 *src/tshewhart_ar1_arl.c 60be25c27a4db0a21d84d8853c9f79f9 *src/xDcusum_arl.c e30b38fec4ae87f8ae199bf0a30b6016 *src/xDewma_arl.c 29e58e38907104709cb82387da0f5935 *src/xDgrsr_arl.c 71f32a11f8a81361e2c6b7f7bb4f58a4 *src/xcusum_ad.c f644f5fd1ac85c5843a9886c31f36e36 *src/xcusum_arl.c eeb348dfb7c4f3b49786d5c77a56029a *src/xcusum_crit.c 5159145d823621d789a60d0f9afcd8f0 *src/xcusum_q.c c80a83da167cb4812d40b0ea4dce8f4e *src/xcusum_sf.c f292e971ef92ca88b66ba558c596d64e *src/xewma_ad.c 5a6d1a5d91f3a56b4eee28cb9d9fbba2 *src/xewma_arl.c 678c15cd432c3022bde490a496cedc04 *src/xewma_arl_f.c 07fc786c9edbae9df4f6a405b644c0bb *src/xewma_arl_prerun.c 924e49d6f154bc51d6e70083c531a661 *src/xewma_crit.c e7d23cc20775cadaae418303bfbc8f3c *src/xewma_q.c b621caf1355258ad4d164cc8e7c98973 *src/xewma_q_prerun.c 901a9013eafee36e06a00884b00e73d9 *src/xewma_res_arl.c b50ac513bfd8b342ab58aa4e8160a549 *src/xewma_sf.c 89fe3b240172c25c37237050cb4ed78a *src/xewma_sf_prerun.c 21ea2dd23de83ac4d3a8337d247c98f3 *src/xgrsr_ad.c 2bbc7b00f38bc2db07f67f287c1dd30c *src/xgrsr_arl.c 963ff7aedda3bb085e576d835bab6c01 *src/xgrsr_crit.c 1a6b03d4e482ef7fafc01e085afc49f0 *src/xsewma_arl.c 46db106c68df8db6a078b69f6cf46244 *src/xsewma_crit.c ce6904e1ee2dd0804d1dbcf0eaec6458 *src/xsewma_q.c ec842eafa53b5f1322273285e64c1648 *src/xsewma_q_crit.c 37996b63005a89201f5562c9061fc442 *src/xsewma_res_arl.c 56cd4e09f23003a9b6b16f0f4b7eb66f *src/xsewma_res_pms.c 925ce8aa0806911a53fe25042e0d6c2b *src/xsewma_sf.c feb70c2804fbe8ead56e7c6f2d7737b7 *src/xshewhart_ar1_arl.c 2b775e05f140e34e322e2875ed100cc2 *src/xtcusum_arl.c 8116ba9aa9671a9465dd2d96b256fe92 *src/xtewma_ad.c bd1a4c72992414e007aa652941932e90 *src/xtewma_arl.c 1c9024238bf1e399728043b268d0eeeb *src/xtewma_q.c 5523b0f49d7bd96031aa3e0ec4791e50 *src/xtewma_sf.c