R/spc.capability.summary.ungrouped.nonnormal.simple.R

In burrm/lolcat: Miscellaneous Useful Functions

#' Calculate Capability Measures - Non-Normally Distributed Data  
#' 
#' Calculate capability measures and potential out of specification parts per million. 
#'
#' @param stat.lsl Lower specification limit (if applicable)
#' @param stat.target Target for process 
#' @param stat.usl Upper specification limit (if applicable)
#' @param stat.lsl.capability Lower specification limit (if applicable) for capability measures
#' @param stat.target.capability Target for process for capability measures
#' @param stat.usl.capability Upper specification limit (if applicable) for capability measures
#' @param stat.lsl.performance Lower specification limit (if applicable) for performance measures
#' @param stat.target.performance Target for process for performance measures
#' @param stat.usl.performance Upper specification limit (if applicable) for performance measures
#' @param process.center.capability Estimate of process center for capability measures
#' @param process.center.performance Estimate of process center for performance measures
#' @param process.variability Estimate of process variability, expressed as variance. Used for performance measures only. 
#' @param process.n.upper Observed count above upper specification limit, used to calculate PPM (parts per million).
#' @param process.n.lower Observed count below lower specification limit, used to calculate PPM (parts per million).
#' @param process.n Total count of subjects/objects, used to calculate PPM (parts per million).
#' @param process.ppm.upper Observed parts per million (PPM) above upper specification limit.
#' @param process.ppm.lower Observed parts per million (PPM) below lower specification limit.
#' @param natural.tolerance Natural tolerance estimate. Used for capability measures.
#' @param p.lower Fit distribution area below LSL.
#' @param p.upper Fit distribution area above USL.
#'
#' @return A data frame with computed measures. 
spc.capability.summary.ungrouped.nonnormal.simple.R <- function(
  stat.lsl = NA,                   #Lower specification limit
  stat.target = NA,                #Nominal process center - target median/mean
  stat.usl = NA,                   #Upper specification limit

  stat.lsl.capability    = stat.lsl,    #Lower specification limit - overridden for capability
  stat.target.capability = stat.target, #Nominal process center - target median/mean - overridden for capability
  stat.usl.capability    = stat.usl,    #Upper specification limit - overridden for capability

  stat.lsl.performance    = stat.lsl,    #Lower specification limit - overridden for performance measures
  stat.target.performance = stat.target, #Nominal process center - target median/mean - overridden for performance measures
  stat.usl.performance    = stat.usl,    #Upper specification limit - overridden for performance measures

  process.center.capability = NA,  #Estimate of process center - median
  process.center.performance = NA, #Estimate of process center - mean
  process.variability = NA,        #Estimate of process variability, expressed as variance, performance measures only
  process.n.upper = NA,            #n above USL
  process.n.lower = NA,            #n below LSL
  process.n = NA,                  #total observed
  process.ppm.upper = round(1000000*process.n.upper/process.n), #observed PPM above USL
  process.ppm.lower = round(1000000*process.n.lower/process.n), #observed PPM below LSL
  natural.tolerance = NA,          #distribution natural tolerance, capability measures only
  p.lower = NA,                    #distribution area below LSL
  p.upper = NA                     #distribution area above USL
) {
  
  if (is.na(stat.lsl.capability) | is.na(stat.usl.capability)) {
    stat.sl.capability <- na.omit(c(stat.lsl.capability, stat.usl.capability))
    stat.sl.performance <- na.omit(c(stat.lsl.performance, stat.usl.performance))

    #Cp
    stat.cp <- spc.capability.cp.simple(
      lower.specification = stat.lsl.capability,
      upper.specification = stat.usl.capability,
      process.center = process.center.capability,
      process.natural.tolerance = natural.tolerance
    )

    #Cpk, need lesser of center - lsl and usl - center
    stat.cpk <- NA
    lower.tail <- NA
    p.to.use <- NA
        
    if (is.na(stat.usl)) {
        p.to.use   <- p.lower
        lower.tail <- T
    } else {
        p.to.use <- p.upper
        lower.tail <- F
    }

    z <- qnorm(
        p = p.to.use,
        lower.tail = lower.tail
    )

    stat.cpk <- abs(z)/3
  

    #Cpm
    stat.cpm <- spc.capability.cpm.simple(
        lower.specification = stat.lsl.capability,
        nominal.center      = stat.target.capability, 
        upper.specification = stat.usl.capability, 
        process.variability = (natural.tolerance/6)^2, 
        process.center = process.center.capability,  
        n.sigma = 6
    )

    s <- sqrt(process.variability)
    
    #Pp
    stat.pp <- spc.capability.cp.simple(
      lower.specification = stat.lsl.performance, 
      upper.specification = stat.usl.performance, 
      process.center = process.center.performance,
      process.natural.tolerance = 6*s
    )

    #Ppk
    stat.ppk <- (2*abs(process.center.performance-stat.sl.performance)/(6*s))

    #Ppm
    stat.ppm <- spc.capability.cpm.simple(
      lower.specification = stat.lsl.performance, 
      nominal.center      = stat.target.performance,
      upper.specification = stat.usl.performance, 
      process.variability = s^2, 
      process.center      = process.center.performance, 
      n.sigma             = 6
    )  

    ppm.lower <- round(1000000*p.lower)
    ppm.upper <- round(1000000*p.upper)
    ppm.total <- sum(na.omit(c(ppm.lower,ppm.upper)))

    process.ppm.total <- sum(na.omit(process.ppm.upper, process.ppm.lower))
    process.oos.total <- sum(na.omit(process.n.upper,   process.n.lower))

    
  }
  else {

    #Cp
    stat.cp <- spc.capability.cp.simple(
      lower.specification = stat.lsl.capability, 
      upper.specification = stat.usl.capability, 
      process.natural.tolerance = natural.tolerance
    )
          
    #Cpk, need lesser of center - lsl and usl - center
    stat.cpk <- NA
    if (process.center.capability >= stat.lsl & process.center.capability <= stat.usl) {
        closer = c(process.center.capability - stat.lsl, stat.usl - process.center.capability)
        lower.tail <- NA
        p.to.use <- NA
        
        if (closer[1] < closer[2]) {
            p.to.use   <- p.lower
            lower.tail <- T
        } else {
            p.to.use <- p.upper
            lower.tail <- F
        }

        z <- qnorm(
            p = p.to.use,
            lower.tail = lower.tail
        )

        stat.cpk <- abs(z)/3
    }
    #Cpm
    stat.cpm <- spc.capability.cpm.simple(
        lower.specification = stat.lsl.capability,
        nominal.center      = stat.target.capability, 
        upper.specification = stat.usl.capability, 
        process.variability = (natural.tolerance/6)^2, 
        process.center = process.center.capability,  
        n.sigma = 6
    )

    s <- sqrt(process.variability)
    
    #Pp
    stat.pp <- spc.capability.cp.simple(
      lower.specification = stat.lsl.performance, 
      upper.specification = stat.usl.performance, 
      process.center = process.center.performance,
      process.natural.tolerance = 6*s
    )

    #Ppk
    stat.ppk <- spc.capability.cpk.simple(
      lower.specification = stat.lsl.performance, 
      upper.specification = stat.usl.performance,
      process.variability = s^2, 
      process.center      = process.center.performance, 
      n.sigma             = 6
    )

    #Ppm
    stat.ppm <- spc.capability.cpm.simple(
      lower.specification = stat.lsl.performance, 
      nominal.center      = stat.target.performance,
      upper.specification = stat.usl.performance, 
      process.variability = s^2, 
      process.center = process.center.performance, 
      n.sigma = 6
    )  

    ppm.lower <- round(1000000*p.lower)
    ppm.upper <- round(1000000*p.upper)
    ppm.total <- ppm.lower+ppm.upper

    process.ppm.total <- sum(na.omit(process.ppm.upper, process.ppm.lower))
    process.oos.total <- sum(na.omit(process.n.upper,   process.n.lower))

  }

  output.table <- data.frame(
    statistic = c(
      "Cp", 
      "Cpk", 
      "Cpm", 
      "Pp", 
      "Ppk", 
      "Ppm",
      "Obs. n / PPM (lower)",
      "Obs. n / PPM (upper)",
      "Obs. n / PPM (total)",
      "Pot. PPM (lower)", 
      "Pot. PPM (upper)", 
      "Pot. PPM (total)"),
    eq = c(
      "=", 
      "=", 
      "=", 
      "=", 
      "=", 
      "=",
      "=",
      "=",
      "=",
      "=", 
      "=", 
      "="),
    n= c(
      "",
      "",
      "",
      "",
      "",
      "",
      process.n.lower,
      process.n.upper,
      process.oos.total,
      "",
      "",
      ""
    ),
    value = c(
      stat.cp,
      stat.cpk,
      stat.cpm,
      stat.pp,
      stat.ppk,
      stat.ppm,
      process.ppm.lower,
      process.ppm.upper,
      process.ppm.total,
      ppm.lower,
      ppm.upper,
      ppm.total
    ),
    stringsAsFactors = F
  )

  output.table
}