From noreply at r-forge.r-project.org Thu Mar 28 14:43:29 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 28 Mar 2013 14:43:29 +0100 (CET) Subject: [Vectis-commits] r4 - pkg/R Message-ID: <20130328134329.D98BB185098@r-forge.r-project.org> Author: cbattles Date: 2013-03-28 14:43:29 +0100 (Thu, 28 Mar 2013) New Revision: 4 Modified: pkg/R/Cap_anal.R Log: Added initial plotting code based on ggplot2 Modified: pkg/R/Cap_anal.R =================================================================== --- pkg/R/Cap_anal.R 2013-03-26 21:58:06 UTC (rev 3) +++ pkg/R/Cap_anal.R 2013-03-28 13:43:29 UTC (rev 4) @@ -167,6 +167,57 @@ PERF["OBGU"] <- 1e6*(length(x[x>USL])/length(x[!is.na(x)])) PERF["OBT"] <- sum(PERF["OBLL"],PERF["OBGU"]) +# Create Plots + x <- as.data.frame(x) + aes_now <- function(...) {structure(list(...), class = "uneval")} + + p <- ggplot(x, aes(x = x)) + + theme(plot.margin = unit(c(3,1,1,1), "lines")) + + p <- p + geom_histogram(aes(y=..density..), + binwidth = diff(range(x))/sqrt(length(x[!is.na(x)])), + color = "black", fill = "blue") + p <- p + geom_density() + p <- p + geom_vline(xintercept = LSL, linetype = 2, size = 1, color = "darkred") + p <- p + geom_vline(xintercept = target, linetype = 2, size = 1, color = "green3") + p <- p + geom_vline(xintercept = USL, linetype = 2, size = 1, color = "darkred") + + p <- p + geom_text(aes_now(label = c("USL","Target","LSL"), + x = c(USL,target,LSL), y = Inf), + hjust = .5, vjust = -1, color = "black", size=5) + p <- p + annotate(geom = "text", + x = LSL, + y = 0, + label = "LSL", + hjust = -0.1, + size = 5, color = "darkred") + p <- p + annotate(geom = "text", + x = target, + y = 0, + label = "TAR", + hjust = -0.1, + size = 5, color = "green3") + p <- p + annotate(geom = "text", + x = USL, + y = 0, + label = "USL", + hjust = 1.1, + size = 5, color = "darkred") + gt <- ggplot_gtable(ggplot_build(p)) + gt$layout$clip[gt$layout$name == "panel"] <- "off" + grid.draw(gt) + +# p <- p + stat_density(geom="path", +# position="identity", +# binwidth = diff(range(x))/sqrt(length(x[!is.na(x)])), +# size = 1) + +# stat_function(fun = dnorm, +# args = with(as.data.frame(x), c(mean(x), sd(x))), +# linetype = 2, size = 1) + + print(gt) + + output <- list(Proc_Data,CPS,PPS,PERF) class(output) <- 'myclass' return(output) From noreply at r-forge.r-project.org Thu Mar 28 21:33:18 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 28 Mar 2013 21:33:18 +0100 (CET) Subject: [Vectis-commits] r5 - pkg/R Message-ID: <20130328203318.72C1C185035@r-forge.r-project.org> Author: cbattles Date: 2013-03-28 21:33:18 +0100 (Thu, 28 Mar 2013) New Revision: 5 Modified: pkg/R/Cap_anal.R Log: Main graph updates: graph cleanup, setting of dynamic limits, colors. Added binwidth parameter and changed automatic method to Freedman-Diaconis Modified: pkg/R/Cap_anal.R =================================================================== --- pkg/R/Cap_anal.R 2013-03-28 13:43:29 UTC (rev 4) +++ pkg/R/Cap_anal.R 2013-03-28 20:33:18 UTC (rev 5) @@ -1,236 +1,284 @@ -vectis.cap <- function(x, - distribution = "normal", - USL = NA, - LSL = NA, - target = NA, - main = "Capabilities Analysis", - sub = "", - groupsize = 1, - mrlength = 2, - alpha = 0.05, - tol = 5.15, - unbias_sub = TRUE, - unbias_overall = FALSE) -{ - if (is.na(target)){ - stop("Target not specified") - } - if (is.na(LSL) & is.na(USL)){ - stop("Upper and Lower Specification Limits not specified") - } - if (groupsize < 1 | groupsize > 50){ - stop("Group Size must be between 1 and 50") - } - if (mrlength < 2){ - stop("Moving Range Length must be greater than or equal to 2") - } - - Lookup <- - structure(list(N = 1:100, - c4 = c(NA, 0.797885, 0.886227, 0.921318, - 0.939986, 0.951533, 0.959369, 0.96503, 0.969311, 0.972659, 0.97535, - 0.977559, 0.979406, 0.980971, 0.982316, 0.983484, 0.984506, 0.98541, - 0.986214, 0.986934, 0.987583, 0.98817, 0.988705, 0.989193, 0.98964, - 0.990052, 0.990433, 0.990786, 0.991113, 0.991418, 0.991703, 0.991969, - 0.992219, 0.992454, 0.992675, 0.992884, 0.99308, 0.993267, 0.993443, - 0.993611, 0.99377, 0.993922, 0.994066, 0.994203, 0.994335, 0.99446, - 0.99458, 0.994695, 0.994806, 0.994911, 0.995013, 0.99511, 0.995204, - 0.995294, 0.995381, 0.995465, 0.995546, 0.995624, 0.995699, 0.995772, - 0.995842, 0.99591, 0.995976, 0.99604, 0.996102, 0.996161, 0.996219, - 0.996276, 0.99633, 0.996383, 0.996435, 0.996485, 0.996534, 0.996581, - 0.996627, 0.996672, 0.996716, 0.996759, 0.9968, 0.996841, 0.99688, - 0.996918, 0.996956, 0.996993, 0.997028, 0.997063, 0.997097, 0.997131, - 0.997163, 0.997195, 0.997226, 0.997257, 0.997286, 0.997315, 0.997344, - 0.997372, 0.997399, 0.997426, 0.997452, 0.997478), - c5 = c(NA, 0.603, 0.463, 0.389, 0.341, 0.308, 0.282, 0.262, 0.246, 0.232, - 0.22, 0.21, 0.202, 0.194, 0.187, 0.181, 0.175, 0.17, 0.166, 0.161, - 0.157, 0.153, 0.15, 0.147, 0.144, NA, NA, NA, NA, NA, NA, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, - NA, NA, NA, NA), - d2 = c(1, 1.128, 1.693, 2.059, 2.326, 2.534, - 2.704, 2.847, 2.97, 3.078, 3.173, 3.258, 3.336, 3.407, 3.472, - 3.532, 3.588, 3.64, 3.689, 3.735, 3.778, 3.819, 3.858, 3.895, - 3.931, 3.965, 3.997, 4.028, 4.058, 4.086, 4.113, 4.139, 4.164, - 4.189, 4.213, 4.236, 4.258, 4.28, 4.301, 4.322, 4.342, 4.361, - 4.38, 4.398, 4.415, 4.432, 4.449, 4.466, 4.482, 4.498, NA, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), - d3 = c(0.82, 0.8525, 0.8884, 0.8794, 0.8641, 0.848, 0.8332, - 0.8198, 0.8078, 0.7971, 0.7873, 0.7785, 0.7704, 0.763, 0.7562, - 0.7499, 0.7441, 0.7386, 0.7335, 0.7287, 0.7242, 0.7199, 0.7159, - 0.7121, 0.7084, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), - d4 = c(1, 0.954, 1.588, 1.978, 2.257, 2.472, 2.645, 2.791, - 2.915, 3.024, 3.121, 3.207, 3.285, 3.356, 3.422, 3.482, 3.538, - 3.591, 3.64, 3.686, 3.73, 3.771, 3.811, 3.847, 3.883, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA)), - .Names = c("N", "c4", "c5", "d2", "d3", "d4"), class = "data.frame", - row.names = c(NA, -100L)) - -# x <- c(3,5,2,3,7,4,9,1,7,5,8,3) -# distribution = "normal" -# USL = 9 -# LSL = 1 -# target = 5 -# main = "Capabilities Analysis" -# sub = "" -# groupsize = 1 -# mrlength = 2 -# alpha = 0.05 -# tol = 5.15 -# unbias_sub = TRUE -# unbias_overall = TRUE - - if (groupsize == 1){ - R_i <- vector(mode = "numeric", length = (length(x[!is.na(x)])-(mrlength-1))) - range_temp <- vector(mode = "numeric", length = mrlength) - for(i in 1:(length(x[!is.na(x)])-(mrlength-1))){ - for(j in i:(i+mrlength-1)){ - range_temp[j+1-i]<-x[j] - } - R_i[i] <- max(range_temp) - min(range_temp) - } - Rbar <- sum(R_i)/(length(x[!is.na(x)])-(mrlength-1)) - - if (unbias_sub) { - S_within <<- Rbar/(Lookup$d2[mrlength]) - } else { - S_within <<- Rbar - } - } - - if (groupsize > 1){ - #Add Here - } - - if (unbias_overall) { - S_overall <- sd(x)/(Lookup$c4[length(x[!is.na(x)])]) - } else { - S_overall <- sd(x) - } - - mu <- mean(x) - - # Process Data - Proc_Data <- vector(mode = "numeric", length = 8) - names(Proc_Data) <- c("LSL","Target","USL","Sample Mean","Number of Obs.", - "StDev(Within)","StDev(Overall)","Group Size") - Proc_Data["LSL"] <- LSL - Proc_Data["Target"] <- target - Proc_Data["USL"] <- USL - Proc_Data["Sample Mean"] <- mu - Proc_Data["Number of Obs."] <- length(x[!is.na(x)]) - Proc_Data["StDev(Within)"] <- S_within - Proc_Data["StDev(Overall)"] <- S_overall - Proc_Data["Group Size"] <- groupsize - - - # Potential Capability Matrix - CPS <- vector(mode = "numeric", length = 5) - names(CPS) <- c("Cp","CPL", "CPU", "Cpk", "CCpk") - CPS["Cp"] <- (USL - LSL)/(tol*S_within) - CPS["CPL"] <- (mu - LSL)/(.5*tol*S_within) - CPS["CPU"] <- (USL - mu)/(.5*tol*S_within) - CPS["Cpk"] <- min(CPS["CPU"],CPS["CPL"]) - CPS["CCpk"] <- min(USL-target,target-LSL)/(.5*tol*S_within) - - # Overall Capability Matrix - PPS <- vector(mode = "numeric", length = 5) - names(PPS) <- c("Pp","PPL", "PPU", "Ppk", "Cpm") - PPS["Pp"] <- (USL - LSL)/(tol*S_overall) - PPS["PPL"] <- (mu - LSL)/(.5*tol*S_overall) - PPS["PPU"] <- (USL - mu)/(.5*tol*S_overall) - PPS["Ppk"] <- min(PPS["PPU"],PPS["PPL"]) - PPS["Cpm"] <- min(USL-target,target-LSL)/(.5*tol*sd(x)) - - #Expected Within/Overall/Observed Performance - PERF <- vector(mode = "numeric", length = 9) - names(PERF) <- c("PWLL","PWGU","PWT","POLL","POGU","POT","OBLL","OBGU","OBT") - PERF["PWLL"] <- 1e6*(1-pnorm((mu-LSL)/S_within)) - PERF["PWGU"] <- 1e6*(1-pnorm((USL-mu)/S_within)) - PERF["PWT"] <- sum(PERF["PWLL"],PERF["PWGU"]) - PERF["POLL"] <- 1e6*(1-pnorm((mu-LSL)/S_overall)) - PERF["POGU"] <- 1e6*(1-pnorm((USL-mu)/S_overall)) - PERF["POT"] <- sum(PERF["POLL"],PERF["POGU"]) - PERF["OBLL"] <- 1e6*(length(x[xUSL])/length(x[!is.na(x)])) - PERF["OBT"] <- sum(PERF["OBLL"],PERF["OBGU"]) - -# Create Plots - x <- as.data.frame(x) - aes_now <- function(...) {structure(list(...), class = "uneval")} - - p <- ggplot(x, aes(x = x)) + - theme(plot.margin = unit(c(3,1,1,1), "lines")) - - p <- p + geom_histogram(aes(y=..density..), - binwidth = diff(range(x))/sqrt(length(x[!is.na(x)])), - color = "black", fill = "blue") - p <- p + geom_density() - p <- p + geom_vline(xintercept = LSL, linetype = 2, size = 1, color = "darkred") - p <- p + geom_vline(xintercept = target, linetype = 2, size = 1, color = "green3") - p <- p + geom_vline(xintercept = USL, linetype = 2, size = 1, color = "darkred") - - p <- p + geom_text(aes_now(label = c("USL","Target","LSL"), - x = c(USL,target,LSL), y = Inf), - hjust = .5, vjust = -1, color = "black", size=5) - p <- p + annotate(geom = "text", - x = LSL, - y = 0, - label = "LSL", - hjust = -0.1, - size = 5, color = "darkred") - p <- p + annotate(geom = "text", - x = target, - y = 0, - label = "TAR", - hjust = -0.1, - size = 5, color = "green3") - p <- p + annotate(geom = "text", - x = USL, - y = 0, - label = "USL", - hjust = 1.1, - size = 5, color = "darkred") - gt <- ggplot_gtable(ggplot_build(p)) - gt$layout$clip[gt$layout$name == "panel"] <- "off" - grid.draw(gt) - -# p <- p + stat_density(geom="path", -# position="identity", -# binwidth = diff(range(x))/sqrt(length(x[!is.na(x)])), -# size = 1) + -# stat_function(fun = dnorm, -# args = with(as.data.frame(x), c(mean(x), sd(x))), -# linetype = 2, size = 1) - - print(gt) - - - output <- list(Proc_Data,CPS,PPS,PERF) - class(output) <- 'myclass' - return(output) -} - -print.myclass <- function(x) { - cat("Capabiliy Analysis","\n") - print(noquote(cbind(`Process Data` = unlist(x[[1]]))), digits = 4) - cat("\n") - print(noquote(cbind(`Potential Capability` = unlist(x[[2]]))), digits = 4) - cat("\n") - print(noquote(cbind(`Overall Capability` = unlist(x[[3]]))), digits = 4) - cat("\n") - print(noquote(cbind(`Performance` = unlist(x[[4]]))), digits = 4) - return(invisible(x)) +vectis.cap <- function(data, + distribution = "normal", + USL = NA, + LSL = NA, + target = NA, + main = "Capabilities Analysis", + sub = "", + groupsize = 1, + mrlength = 2, + alpha = 0.05, + tol = 5.15, + unbias_sub = TRUE, + unbias_overall = FALSE, + density = FALSE, + binwidth = -1 + ) +{ + library(ggplot2) + library(grid) + + if (is.na(target)){ + stop("Target not specified") + } + if (is.na(LSL) & is.na(USL)){ + stop("Upper and Lower Specification Limits not specified") + } + if (groupsize < 1 | groupsize > 50){ + stop("Group Size must be between 1 and 50") + } + if (mrlength < 2){ + stop("Moving Range Length must be greater than or equal to 2") + } + + Lookup <- + structure(list(N = 1:100, + c4 = c(NA, 0.797885, 0.886227, 0.921318, + 0.939986, 0.951533, 0.959369, 0.96503, 0.969311, 0.972659, 0.97535, + 0.977559, 0.979406, 0.980971, 0.982316, 0.983484, 0.984506, 0.98541, + 0.986214, 0.986934, 0.987583, 0.98817, 0.988705, 0.989193, 0.98964, + 0.990052, 0.990433, 0.990786, 0.991113, 0.991418, 0.991703, 0.991969, + 0.992219, 0.992454, 0.992675, 0.992884, 0.99308, 0.993267, 0.993443, + 0.993611, 0.99377, 0.993922, 0.994066, 0.994203, 0.994335, 0.99446, + 0.99458, 0.994695, 0.994806, 0.994911, 0.995013, 0.99511, 0.995204, + 0.995294, 0.995381, 0.995465, 0.995546, 0.995624, 0.995699, 0.995772, + 0.995842, 0.99591, 0.995976, 0.99604, 0.996102, 0.996161, 0.996219, + 0.996276, 0.99633, 0.996383, 0.996435, 0.996485, 0.996534, 0.996581, + 0.996627, 0.996672, 0.996716, 0.996759, 0.9968, 0.996841, 0.99688, + 0.996918, 0.996956, 0.996993, 0.997028, 0.997063, 0.997097, 0.997131, + 0.997163, 0.997195, 0.997226, 0.997257, 0.997286, 0.997315, 0.997344, + 0.997372, 0.997399, 0.997426, 0.997452, 0.997478), + c5 = c(NA, 0.603, 0.463, 0.389, 0.341, 0.308, 0.282, 0.262, 0.246, 0.232, + 0.22, 0.21, 0.202, 0.194, 0.187, 0.181, 0.175, 0.17, 0.166, 0.161, + 0.157, 0.153, 0.15, 0.147, 0.144, NA, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA), + d2 = c(1, 1.128, 1.693, 2.059, 2.326, 2.534, + 2.704, 2.847, 2.97, 3.078, 3.173, 3.258, 3.336, 3.407, 3.472, + 3.532, 3.588, 3.64, 3.689, 3.735, 3.778, 3.819, 3.858, 3.895, + 3.931, 3.965, 3.997, 4.028, 4.058, 4.086, 4.113, 4.139, 4.164, + 4.189, 4.213, 4.236, 4.258, 4.28, 4.301, 4.322, 4.342, 4.361, + 4.38, 4.398, 4.415, 4.432, 4.449, 4.466, 4.482, 4.498, NA, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), + d3 = c(0.82, 0.8525, 0.8884, 0.8794, 0.8641, 0.848, 0.8332, + 0.8198, 0.8078, 0.7971, 0.7873, 0.7785, 0.7704, 0.763, 0.7562, + 0.7499, 0.7441, 0.7386, 0.7335, 0.7287, 0.7242, 0.7199, 0.7159, + 0.7121, 0.7084, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA), + d4 = c(1, 0.954, 1.588, 1.978, 2.257, 2.472, 2.645, 2.791, + 2.915, 3.024, 3.121, 3.207, 3.285, 3.356, 3.422, 3.482, 3.538, + 3.591, 3.64, 3.686, 3.73, 3.771, 3.811, 3.847, 3.883, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, + NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA)), + .Names = c("N", "c4", "c5", "d2", "d3", "d4"), class = "data.frame", + row.names = c(NA, -100L)) + +# x <- c(3,5,2,3,7,4,9,1,7,5,8,3) +# distribution = "normal" +# USL = 9 +# LSL = 1 +# target = 5 +# main = "Capabilities Analysis" +# sub = "" +# groupsize = 1 +# mrlength = 2 +# alpha = 0.05 +# tol = 5.15 +# unbias_sub = TRUE +# unbias_overall = TRUE + + if (groupsize == 1){ + R_i <- vector(mode = "numeric", length = (length(data[!is.na(data)])-(mrlength-1))) + range_temp <- vector(mode = "numeric", length = mrlength) + for(i in 1:(length(data[!is.na(data)])-(mrlength-1))){ + for(j in i:(i+mrlength-1)){ + range_temp[j+1-i]<-data[j] + } + R_i[i] <- max(range_temp) - min(range_temp) + } + Rbar <- sum(R_i)/(length(data[!is.na(data)])-(mrlength-1)) + + if (unbias_sub) { + S_within <<- Rbar/(Lookup$d2[mrlength]) + } else { + S_within <<- Rbar + } + } + + if (groupsize > 1){ + #Add Here + } + + if (unbias_overall) { + S_overall <- sd(data)/(Lookup$c4[length(data[!is.na(data)])]) + } else { + S_overall <- sd(data) + } + + mu <- mean(data) + + # Process Data + Proc_Data <- vector(mode = "numeric", length = 8) + names(Proc_Data) <- c("LSL","Target","USL","Sample Mean","Number of Obs.", + "StDev(Within)","StDev(Overall)","Group Size") + Proc_Data["LSL"] <- LSL + Proc_Data["Target"] <- target + Proc_Data["USL"] <- USL + Proc_Data["Sample Mean"] <- mu + Proc_Data["Number of Obs."] <- length(data[!is.na(data)]) + Proc_Data["StDev(Within)"] <- S_within + Proc_Data["StDev(Overall)"] <- S_overall + Proc_Data["Group Size"] <- groupsize + + + # Potential Capability Matrix + CPS <- vector(mode = "numeric", length = 5) + names(CPS) <- c("Cp","CPL", "CPU", "Cpk", "CCpk") + CPS["Cp"] <- (USL - LSL)/(tol*S_within) + CPS["CPL"] <- (mu - LSL)/(.5*tol*S_within) + CPS["CPU"] <- (USL - mu)/(.5*tol*S_within) + CPS["Cpk"] <- min(CPS["CPU"],CPS["CPL"]) + CPS["CCpk"] <- min(USL-target,target-LSL)/(.5*tol*S_within) + + # Overall Capability Matrix + PPS <- vector(mode = "numeric", length = 5) + names(PPS) <- c("Pp","PPL", "PPU", "Ppk", "Cpm") + PPS["Pp"] <- (USL - LSL)/(tol*S_overall) + PPS["PPL"] <- (mu - LSL)/(.5*tol*S_overall) + PPS["PPU"] <- (USL - mu)/(.5*tol*S_overall) + PPS["Ppk"] <- min(PPS["PPU"],PPS["PPL"]) + PPS["Cpm"] <- min(USL-target,target-LSL)/(.5*tol*sd(data)) + + #Expected Within/Overall/Observed Performance + PERF <- vector(mode = "numeric", length = 9) + names(PERF) <- c("PWLL","PWGU","PWT","POLL","POGU","POT","OBLL","OBGU","OBT") + PERF["PWLL"] <- 1e6*(1-pnorm((mu-LSL)/S_within)) + PERF["PWGU"] <- 1e6*(1-pnorm((USL-mu)/S_within)) + PERF["PWT"] <- sum(PERF["PWLL"],PERF["PWGU"]) + PERF["POLL"] <- 1e6*(1-pnorm((mu-LSL)/S_overall)) + PERF["POGU"] <- 1e6*(1-pnorm((USL-mu)/S_overall)) + PERF["POT"] <- sum(PERF["POLL"],PERF["POGU"]) + PERF["OBLL"] <- 1e6*(length(data[dataUSL])/length(data[!is.na(data)])) + PERF["OBT"] <- sum(PERF["OBLL"],PERF["OBGU"]) + + #Determine max densities for plot limits + + if(density) dens_max <- max(density(data)[[2]]) else dens_max <- 0 + freq_max <- max(hist(as.vector(data), plot = FALSE)$density) + with_max <- dnorm(mean(data), mean = mean(data),sd = S_within) + over_max <- dnorm(mean(data), mean = mean(data),sd = S_overall) + + + #Calculate the binwidth if not specified + if (binwidth == -1) { + #Freedman-Diaconis + binwidth = 2 * IQR(data) / (length(data[!is.na(data)])^(1/3)) + #Square-root choice + #binwidth = diff(range(data))/sqrt(length(data[!is.na(data)])) + } + +# Create Plots + data <- as.data.frame(data) + aes_now <- function(...) {structure(list(...), class = "uneval")} + + p <- ggplot(data, aes(x = data)) + + theme(plot.margin = unit(c(3,1,1,1), "lines"), + panel.grid.minor = element_blank(), + panel.grid.major = element_blank(), + panel.background = element_rect(fill = NA, color = "gray0"), + axis.title.y = element_blank(), + axis.title.x = element_blank(), + axis.ticks.y = element_blank(), + axis.text.y = element_blank(), + axis.text.x = element_text(size = 15)) + + coord_cartesian(ylim = c(0, max(1.05 * dens_max, 1.05 * freq_max, + 1.05 * with_max, 1.05 * over_max)), + xlim = c(min(min(data),1.1 * LSL - 0.1 * USL, target - 3 * S_within, + target - 3 * S_overall), + max(max(data),1.1 * USL - 0.1 * LSL, target + 3 * S_within, + target + 3 * S_overall))) + + xlim(min(min(data),1.1 * LSL - 0.1 * USL, target - 3 * S_within, target - 3 * S_overall), + max(max(data),1.1 * USL - 0.1 * LSL, target + 3 * S_within, target + 3 * S_overall)) + + ylim(0, max(1.05 * dens_max, 1.05 * freq_max, + 1.05 * with_max, 1.05 * over_max)) + + + p <- p + geom_histogram(aes(y=..density..), + binwidth = binwidth, + color = "black", fill = "slategray1", position = "identity") + + if(density) {p <- p + geom_line(stat="density", size = 1.1, + color = "dodgerblue3", position="identity")} + + p <- p + geom_vline(xintercept = LSL, linetype = 5, size = .65, color = "red3") + p <- p + geom_vline(xintercept = target, linetype = 5, size = .65, color = "green3") + p <- p + geom_vline(xintercept = USL, linetype = 5, size = .65, color = "red3") + + p <- p + geom_text(aes_now(label = c("USL"), x = c(USL), y = Inf, family = "sans"), + hjust = .5, vjust = -1, color = "red3", size=5) + p <- p + geom_text(aes_now(label = c("LSL"), x = c(LSL), y = Inf, family = "sans"), + hjust = .5, vjust = -1, color = "red3", size=5) + p <- p + geom_text(aes_now(label = c("Target"), x = c(target), y = Inf, family = "sans"), + hjust = .5, vjust = -1, color = "green3", size=5) + + p <- p + stat_function(fun = dnorm,args=list(mean = mu, sd = S_within), + color = "red3", size = 1.1, linetype = 1) + p <- p + stat_function(fun = dnorm,args=list(mean = mu, sd = S_overall), + color = "gray0", size = 1.1, linetype = 2) + +# p <- p + opts(panel.background = theme_rect()) + +# p <- p + annotate(geom = "text", +# x = LSL, +# y = 0, +# label = "LSL", +# hjust = -0.1, +# size = 5, color = "darkred") +# p <- p + annotate(geom = "text", +# x = target, +# y = 0, +# label = "TAR", +# hjust = -0.1, +# size = 5, color = "green3") +# p <- p + annotate(geom = "text", +# x = USL, +# y = 0, +# label = "USL", +# hjust = 1.1, +# size = 5, color = "darkred") + + # Disable Clipping + gt <- ggplot_gtable(ggplot_build(p)) + gt$layout$clip[gt$layout$name == "panel"] <- "off" + grid.draw(gt) + + print(gt) + + output <- list(Proc_Data,CPS,PPS,PERF) + class(output) <- 'myclass' + return(output) +} + +print.myclass <- function(x) { + cat("Capabiliy Analysis","\n") + print(noquote(cbind(`Process Data` = unlist(x[[1]]))), digits = 4) + cat("\n") + print(noquote(cbind(`Potential Capability` = unlist(x[[2]]))), digits = 4) + cat("\n") + print(noquote(cbind(`Overall Capability` = unlist(x[[3]]))), digits = 4) + cat("\n") + print(noquote(cbind(`Performance` = unlist(x[[4]]))), digits = 4) + return(invisible(x)) } \ No newline at end of file From noreply at r-forge.r-project.org Thu Mar 28 21:58:51 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 28 Mar 2013 21:58:51 +0100 (CET) Subject: [Vectis-commits] r6 - in pkg: R man Message-ID: <20130328205851.5E663184FA1@r-forge.r-project.org> Author: cbattles Date: 2013-03-28 21:58:50 +0100 (Thu, 28 Mar 2013) New Revision: 6 Modified: pkg/R/Cap_anal.R pkg/man/Cap_anal.Rd Log: Added plot = TRUE/FALSE as a parameter Updated documentation Code commenting Modified: pkg/R/Cap_anal.R =================================================================== --- pkg/R/Cap_anal.R 2013-03-28 20:33:18 UTC (rev 5) +++ pkg/R/Cap_anal.R 2013-03-28 20:58:50 UTC (rev 6) @@ -1,3 +1,4 @@ +#Function to generate text and graphical capabilities analyses on a data set vectis.cap <- function(data, distribution = "normal", USL = NA, @@ -12,7 +13,8 @@ unbias_sub = TRUE, unbias_overall = FALSE, density = FALSE, - binwidth = -1 + binwidth = -1, + plot = TRUE ) { library(ggplot2) @@ -21,10 +23,10 @@ if (is.na(target)){ stop("Target not specified") } - if (is.na(LSL) & is.na(USL)){ + if (is.na(LSL) && is.na(USL)){ stop("Upper and Lower Specification Limits not specified") } - if (groupsize < 1 | groupsize > 50){ + if (groupsize < 1 || groupsize > 50){ stop("Group Size must be between 1 and 50") } if (mrlength < 2){ @@ -98,6 +100,10 @@ # unbias_sub = TRUE # unbias_overall = TRUE + # Estimate the standard deviation within subgroups by the average of the moving range + # Add other methods here for subgroup size of 1 + + if (groupsize == 1){ R_i <- vector(mode = "numeric", length = (length(data[!is.na(data)])-(mrlength-1))) range_temp <- vector(mode = "numeric", length = mrlength) @@ -120,6 +126,7 @@ #Add Here } + # Calculate overall standard deviation and apply the unbiasing constant if desired if (unbias_overall) { S_overall <- sd(data)/(Lookup$c4[length(data[!is.na(data)])]) } else { @@ -140,8 +147,7 @@ Proc_Data["StDev(Within)"] <- S_within Proc_Data["StDev(Overall)"] <- S_overall Proc_Data["Group Size"] <- groupsize - - + # Potential Capability Matrix CPS <- vector(mode = "numeric", length = 5) names(CPS) <- c("Cp","CPL", "CPU", "Cpk", "CCpk") @@ -173,14 +179,14 @@ PERF["OBGU"] <- 1e6*(length(data[data>USL])/length(data[!is.na(data)])) PERF["OBT"] <- sum(PERF["OBLL"],PERF["OBGU"]) - #Determine max densities for plot limits + if(plot){ + #Determine max densities for plot limits if(density) dens_max <- max(density(data)[[2]]) else dens_max <- 0 freq_max <- max(hist(as.vector(data), plot = FALSE)$density) with_max <- dnorm(mean(data), mean = mean(data),sd = S_within) over_max <- dnorm(mean(data), mean = mean(data),sd = S_overall) - - + #Calculate the binwidth if not specified if (binwidth == -1) { #Freedman-Diaconis @@ -189,10 +195,13 @@ #binwidth = diff(range(data))/sqrt(length(data[!is.na(data)])) } -# Create Plots + #Create Plots data <- as.data.frame(data) + + #define function for aes that evaluates expressions aes_now <- function(...) {structure(list(...), class = "uneval")} + #Initial plot definition p <- ggplot(data, aes(x = data)) + theme(plot.margin = unit(c(3,1,1,1), "lines"), panel.grid.minor = element_blank(), @@ -213,15 +222,16 @@ max(max(data),1.1 * USL - 0.1 * LSL, target + 3 * S_within, target + 3 * S_overall)) + ylim(0, max(1.05 * dens_max, 1.05 * freq_max, 1.05 * with_max, 1.05 * over_max)) - + #Add histogram p <- p + geom_histogram(aes(y=..density..), binwidth = binwidth, color = "black", fill = "slategray1", position = "identity") + #Add Density if(density) {p <- p + geom_line(stat="density", size = 1.1, color = "dodgerblue3", position="identity")} - + #Add Spec Limits and labels p <- p + geom_vline(xintercept = LSL, linetype = 5, size = .65, color = "red3") p <- p + geom_vline(xintercept = target, linetype = 5, size = .65, color = "green3") p <- p + geom_vline(xintercept = USL, linetype = 5, size = .65, color = "red3") @@ -233,44 +243,28 @@ p <- p + geom_text(aes_now(label = c("Target"), x = c(target), y = Inf, family = "sans"), hjust = .5, vjust = -1, color = "green3", size=5) + #Add within and overall distribution lines p <- p + stat_function(fun = dnorm,args=list(mean = mu, sd = S_within), color = "red3", size = 1.1, linetype = 1) p <- p + stat_function(fun = dnorm,args=list(mean = mu, sd = S_overall), color = "gray0", size = 1.1, linetype = 2) -# p <- p + opts(panel.background = theme_rect()) - -# p <- p + annotate(geom = "text", -# x = LSL, -# y = 0, -# label = "LSL", -# hjust = -0.1, -# size = 5, color = "darkred") -# p <- p + annotate(geom = "text", -# x = target, -# y = 0, -# label = "TAR", -# hjust = -0.1, -# size = 5, color = "green3") -# p <- p + annotate(geom = "text", -# x = USL, -# y = 0, -# label = "USL", -# hjust = 1.1, -# size = 5, color = "darkred") - - # Disable Clipping + #Disable Clipping gt <- ggplot_gtable(ggplot_build(p)) gt$layout$clip[gt$layout$name == "panel"] <- "off" grid.draw(gt) + #Render plot print(gt) + } + #Define output output <- list(Proc_Data,CPS,PPS,PERF) class(output) <- 'myclass' return(output) } +#Format Text Output print.myclass <- function(x) { cat("Capabiliy Analysis","\n") print(noquote(cbind(`Process Data` = unlist(x[[1]]))), digits = 4) Modified: pkg/man/Cap_anal.Rd =================================================================== --- pkg/man/Cap_anal.Rd 2013-03-28 20:33:18 UTC (rev 5) +++ pkg/man/Cap_anal.Rd 2013-03-28 20:58:50 UTC (rev 6) @@ -1,78 +1,85 @@ -\name{vectis.cap} -\alias{vectis.cap} -%- Also NEED an '\alias' for EACH other topic documented here. -\title{ -Function to Compute and Display Process Capability -} -\description{ -Computes the process capability of a continuous variable -} -\usage{ -vectis.cap (x, distribution = "normal", - USL = NA, - LSL = NA, - target = NA, - main = "Capabilities Analysis", - sub = "", - groupsize = 1, - mrlength = 2, - alpha = 0.05, - tol = 5.15, - unbias_sub = TRUE, - unbias_overall = FALSE) -} -%- maybe also 'usage' for other objects documented here. -\arguments{ - \item{x}{Data values} - \item{distribution}{Distribution of sampled data. Currently only "normal" is supported.} - \item{USL}{Upper Spec Limit} - \item{LSL}{Lower Spec Limit} - \item{target}{Target} - \item{main}{Chart Title} - \item{sub}{Chart Subtitle} - \item{groupsize}{Group size for grouped data. Data must be sorted by groups. Currently only a groupsize of 1 is supported.} - \item{mrlength}{Number of observations used in the moving range to compute the within standard deviation for groupsize = 1.} - \item{alpha}{Probability of a Type I error} - \item{tol}{Sigma multiplier for capabilities statistics. Usually defined as 5.15 or 6} - \item{unbias_sub}{Logical value as to whether the subgroup standard deviation should include the unbiasing constant. Default is TRUE} - \item{unbias_overall}{Logical value as to whether the overall standard deviation should include the unbiasing constant. Default is FALSE} -} -\details{ -%% ~~ If necessary, more details than the description above ~~ -} -\value{ -%% ~Describe the value returned -%% If it is a LIST, use -%% \item{comp1 }{Description of 'comp1'} -%% \item{comp2 }{Description of 'comp2'} -%% ... -} -\references{ -%% ~put references to the literature/web site here ~ -} -\author{ -Christopher Battles -} -\note{ -%% ~~further notes~~ -} - -%% ~Make other sections like Warning with \section{Warning }{....} ~ - -\seealso{ -%% ~~objects to See Also as \code{\link{help}}, ~~~ -} -\examples{ -##---- Should be DIRECTLY executable !! ---- -##-- ==> Define data, use random, -##-- or do help(data=index) for the standard data sets. - -## The function is currently defined as -function (x) -{ - } -} -% Add one or more standard keywords, see file 'KEYWORDS' in the -% R documentation directory. -\keyword{ ~kwd1 } -\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line +\name{vectis.cap} +\alias{vectis.cap} +%- Also NEED an '\alias' for EACH other topic documented here. +\title{ +Function to Compute and Display Process Capability +} +\description{ +Computes the process capability of a continuous variable +} +\usage{ +vectis.cap(data, + distribution = "normal", + USL = NA, + LSL = NA, + target = NA, + main = "Capabilities Analysis", + sub = "", + groupsize = 1, + mrlength = 2, + alpha = 0.05, + tol = 5.15, + unbias_sub = TRUE, + unbias_overall = FALSE + density = FALSE, + binwidth = -1 + plot = TRUE) +} +%- maybe also 'usage' for other objects documented here. +\arguments{ + \item{x}{Data values} + \item{distribution}{Distribution of sampled data. Currently only "normal" is supported.} + \item{USL}{Upper Spec Limit} + \item{LSL}{Lower Spec Limit} + \item{target}{Target} + \item{main}{Chart Title} + \item{sub}{Chart Subtitle} + \item{groupsize}{Group size for grouped data. Data must be sorted by groups. Currently only a groupsize of 1 is supported.} + \item{mrlength}{Number of observations used in the moving range to compute the within standard deviation for groupsize = 1.} + \item{alpha}{Probability of a Type I error.} + \item{tol}{Sigma multiplier for capabilities statistics. Usually defined as 5.15 or 6.} + \item{unbias_sub}{Logical value as to whether the subgroup standard deviation should include the unbiasing constant. Default is TRUE.} + \item{unbias_overall}{Logical value as to whether the overall standard deviation should include the unbiasing constant. Default is FALSE.} + \item{density}{Logical value to control the display of the density curve. Default is FALSE.} + \item{binwidth}{Overrides automatic determination of bin width in histogram. If set to -1 (default) then the function automatically calculates the optimum binwidth.} + \item{plot}{Logical value to control plotting. Default is TRUE} +} +\details{ +%% ~~ If necessary, more details than the description above ~~ +} +\value{ +%% ~Describe the value returned +%% If it is a LIST, use +%% \item{comp1 }{Description of 'comp1'} +%% \item{comp2 }{Description of 'comp2'} +%% ... +} +\references{ +%% ~put references to the literature/web site here ~ +} +\author{ +Christopher Battles +} +\note{ +%% ~~further notes~~ +} + +%% ~Make other sections like Warning with \section{Warning }{....} ~ + +\seealso{ +%% ~~objects to See Also as \code{\link{help}}, ~~~ +} +\examples{ +##---- Should be DIRECTLY executable !! ---- +##-- ==> Define data, use random, +##-- or do help(data=index) for the standard data sets. + +## The function is currently defined as +function (x) +{ + } +} +% Add one or more standard keywords, see file 'KEYWORDS' in the +% R documentation directory. +\keyword{ ~kwd1 } +\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line