https://github.com/cran/IQCC
Raw File
Tip revision: ef4202fc61e884dce81758e0f31c6f1ae429e523 authored by Emanuel P. Barbosa on 10 March 2010, 00:00:00 UTC
version 0.6
Tip revision: ef4202f
cchart.u.R
cchart.u <- function(x1 = NULL, n1 = NULL, type = "norm", u1 = NULL, x2 = NULL, n2 = NULL, lambda = NULL, u2 = NULL)
{
    if((!is.null(n1)) && (!is.null(x1) || !is.null(u1)))
        OK1 = TRUE
    else
        OK1 = FALSE
    if(!is.null(n2) && (!is.null(x2) || !is.null(u2)) && (OK1 || !is.null(lambda)))
        OK2 = TRUE
    else
        OK2 = FALSE
    
#-- Error messages
    if(!OK1 && !OK2)
    {
        if(is.null(x1) && is.null(n1) && is.null(u1))
            return("Phase I data and samples sizes are missing")
        else
        {
            if(is.null(n1))
                return("Phase I samples sizes not specified")
            else
                return("Phase I data is missing")
        }
    }
    if(!OK2)
    {
        if(is.null(n2) && (!is.null(x2) || !is.null(u2)))
            return("Phase II samples sizes not specified")
        if(!is.null(n2) && (is.null(x2) && is.null(u2)))
            return("Phase II data is missing")
        if(!is.null(x2) && !is.null(n2) && !is.null(u2))
            return("Information about phase I is missing")
    }

#-- Phase I
    if(OK1 && !OK2)
    {
        if(!is.null(x1))
        {
            m1 <- length(x1)
            if(length(n1) != length(x1))
                return("The arguments x1 and n1 must have the same length")
        }
        if(!is.null(u1))
        {
            m1 <- length(u1)
            if(length(n1) != length(u1))
                return("The arguments u1 and n1 must have the same length")
        }
        if(is.null(u1))
            u1 <- x1 / n1
        if(is.null(x1))
            x1 <- u1 * n1
        lambda <- mean(u1)
        l <- matrix(nrow = m1, ncol = 1)
#------ Shewhart
        if(type == "norm")
        {
            u <- matrix(nrow = m1, ncol = 1)
            for(i in 1:m1)
            {
                UCL <- lambda + (3 * sqrt(lambda / n1[i]))
                u[i, ] <- UCL
                LCL <- lambda - (3 * sqrt(lambda / n1[i]))
                l[i, ] <- LCL
            }
            qcc(x1, type = "u", n1, limits = c(l, u), center = lambda, title = "Shewhart u-chart (phase I)")
        }
#------ Cornish-Fisher
        if(type == "CF")
        {
            u <- matrix(nrow = m1, ncol = 1)
            for(i in 1:m1)
            {
                UCL <- lambda + (3 * sqrt(lambda / n1[i])) + (4 / (3 * n1[i])) - (1 / ((3 * n1[i]) * sqrt(lambda * n1[i])))
                u[i, ] <- UCL
                LCL <- lambda - (3 * sqrt(lambda / n1[i])) + (4 / (3 * n1[i])) - (1 / ((3 * n1[i]) * sqrt(lambda * n1[i])))
                l[i, ] <- LCL
            }
            qcc(x1, type = "u", n1, limits = c(l, u), center = lambda, title = "Cornish-Fisher u-exact (phase I)")
        }
#------ Standardized
        if(type == "std")
        {
            for(i in 1:m1)
            {
                z <- (u1[i] - lambda) / sqrt(lambda / n1[i])
                l[i, ] <- z
            }
            std <- l * n1
            qcc(std, type = "u", n1, center = 0, limits = c(-3, 3), title = "Stardardized u-chart (phase I)")
        }
    }
#-- Phase II
    if(OK2)
    {
        if(!is.null(x2))
        {
            m2 <- length(x2)
            if(length(n2) != length(x2))
                return("The arguments x2 and n2 must have the same length")
        }
        if(!is.null(u2))
        {
            m2 <- length(u2)
            if(length(n2) != length(u2))
                return("The arguments u2 and n2 must have the same length")
        }
        if(is.null(u2))
            u2 <- x2 / n2
        if(is.null(x2))
            x2 <- u2 * n2
        if(is.null(lambda))
        {
            if(is.null(u1))
                u1 <- x1 / n1
            lambda <- mean(u1)
        }
        l <- matrix(nrow = m2, ncol = 1)
#------ Shewart
        if(type == "norm")
        {
            u <- matrix(nrow = m2, ncol = 1)
            for(i in 1:m2)
            {
                UCL <- lambda + (3 * sqrt(lambda / n2[i]))
                u[i, ] <- UCL
                LCL <- lambda - (3 * sqrt(lambda / n2[i]))
                l[i, ] <- LCL
            }
            qcc(x2, type = "u", n2, limits = c(l, u), center = lambda, title = "Shewart u-chart (phase II)")
        }
#------ Cornish-Fisher
        if(type == "CF")
        {
            u <- matrix(nrow = m2, ncol = 1)
            for(i in 1:m2)
            {
                UCL <- lambda + (3 * sqrt(lambda / n2[i])) + (4 / (3 * n2[i])) - (1 / ((3 * n2[i]) * sqrt(lambda * n2[i])))
                u[i, ] <- UCL
                LCL <- lambda - (3 * sqrt(lambda / n2[i])) + (4 / (3 * n2[i])) - (1 / ((3 * n2[i]) * sqrt(lambda * n2[i])))
                l[i, ] <- LCL
            }
            qcc(x2, type = "u", n2, limits = c(l, u), center = lambda, title = "Cornish-Fisher u-exact (phase II)")
        }
#------ Standardized
        if(type == "std")
        {
            for(i in 1:m2)
            {
                z <- (u2[i] - lambda) / sqrt(lambda / n2[i])
                l[i, ] <- z
            }
            std <- l * n2
            qcc(std, type = "u", n2, center = 0, limits = c(-3, 3), title = "Stardardized u-chart (phase II)")
        }
    }
}
back to top