R Notebook
Control Estadistico de la Calidad
Ingeniería Industrial ~ Facultad de Ingeniería y Arquitectura
Introduccion al uso de R Studio para CEC 2022-1
Presentado por: José Miguel López Z
Docente: Orlando Valencia R
knitr::include_graphics("LOGOUNAL.png")
Librerías
Cargár páquetes para el Control Estadístico de la Cálidad y complementarios para esta revision.
library(qcc)## Package 'qcc' version 2.7## Type 'citation("qcc")' for citing this R package in publications.library(readxl)
library(tidyverse)## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.1 ──## ✔ ggplot2 3.3.6 ✔ purrr 0.3.4
## ✔ tibble 3.1.7 ✔ dplyr 1.0.9
## ✔ tidyr 1.2.0 ✔ stringr 1.4.0
## ✔ readr 2.1.2 ✔ forcats 0.5.1## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()library(stringr)
library(reshape)##
## Attaching package: 'reshape'## The following object is masked from 'package:dplyr':
##
## rename## The following objects are masked from 'package:tidyr':
##
## expand, smithslibrary(qicharts)## qicharts will no longer be maintained. Please consider moving to qicharts2: https://anhoej.github.io/qicharts2/.library(qicharts2)##
## Attaching package: 'qicharts2'## The following objects are masked from 'package:qicharts':
##
## paretochart, qiclibrary(DT)
library(mlbench)
library(MSQC)## Warning in rgl.init(initValue, onlyNULL): RGL: unable to open X11 display## Warning: 'rgl.init' failed, running with 'rgl.useNULL = TRUE'.library("MSQC", lib.loc="~/R/win-library/3.1")
library(SixSigma)
library(scatterplot3d)
#library(qualityTools)Diagrama de Ishikawa :: Diagrama de Causa Efecto
Este diagrama nos permite identificar causas directamente relacionadas con un problema central que abarca la participacion de las 6 M como parte de la cadena de valor de la empresa y del proceso. Así, tener presente los metodos, mediciones, maquinaria, mano de obra, materiales y medio ambiente, genera una perspectiva global que deriva el problema comprendiendo la sinergia para el ambito de actuación.
cause.and.effect(cause=list(Measurements=c("Micrometers", "Microscopes", "Inspectors"),
Materials=c("Alloys", "Lubricants", "Suppliers"),
Personnel=c("Shifts", "Supervisors", "Training", "Operators"),
Environment=c("Condensation", "Moisture"),
Methods=c("Brake", "Engager", "Angle"),
Machines=c("Speed", "Lathes", "Bits", "Sockets")),
effect="Surface Flaws")
Diagrama de Pareto
La ley del 80/20 representada por el diagrama de pareto nos permite identificar los muchos triviales y pocos vitales involucrados en el estudio. De esta manera comprender que las variables o problemas de mayor relevancia se centra en “pocos vitales” que deben ser corregidos o son altamente significativos.
defectos<-c(42,20,10,104,14,4,6)
names(defectos)<-c("A","B","C","D","E","F","G")
pareto.chart(defectos, ylab = "frecuencia", xlab = "Defectos", las=1,main="Diagrama de Pareto")
##
## Pareto chart analysis for defectos
## Frequency Cum.Freq. Percentage Cum.Percent.
## D 104 104 52 52
## A 42 146 21 73
## B 20 166 10 83
## E 14 180 7 90
## C 10 190 5 95
## G 6 196 3 98
## F 4 200 2 100Libreria QCC :: Quality Control Charts
Esta libreria nos permite generar las cartas de control estadistico de la calidad con un objeto de clase “qcc” el cual puede ser graficado. Así se analizan importantes graficas como las curvas caracteristicas operartivas OC, Carta Schewhart, indices de capacidad del proceso y mas.
library(qcc)Generamos datos de diferentes mediciones de diametro para seleccionar muestras por 25 días. Tamaño de muestra constante.
muestra<-rep(1:40,each=5,len=200);muestra## [1] 1 1 1 1 1 2 2 2 2 2 3 3 3 3 3 4 4 4 4 4 5 5 5 5 5
## [26] 6 6 6 6 6 7 7 7 7 7 8 8 8 8 8 9 9 9 9 9 10 10 10 10 10
## [51] 11 11 11 11 11 12 12 12 12 12 13 13 13 13 13 14 14 14 14 14 15 15 15 15 15
## [76] 16 16 16 16 16 17 17 17 17 17 18 18 18 18 18 19 19 19 19 19 20 20 20 20 20
## [101] 21 21 21 21 21 22 22 22 22 22 23 23 23 23 23 24 24 24 24 24 25 25 25 25 25
## [126] 26 26 26 26 26 27 27 27 27 27 28 28 28 28 28 29 29 29 29 29 30 30 30 30 30
## [151] 31 31 31 31 31 32 32 32 32 32 33 33 33 33 33 34 34 34 34 34 35 35 35 35 35
## [176] 36 36 36 36 36 37 37 37 37 37 38 38 38 38 38 39 39 39 39 39 40 40 40 40 40diametros<-c(74.030,74.002,74.019,73.992,74.008,73.995,73.992,74.001,74.011,
74.004,73.988,74.024,74.021,74.005,74.002,74.002,73.996,73.993,74.015,74.009,
73.992,74.007,74.015,73.989,74.014,74.009,73.994,73.997,73.985,73.993,73.995,
74.006,73.994,74.000,74.005,73.985,74.003,73.993,74.015,73.988,74.008,73.995,
74.009,74.005,74.004,73.998,74.000,73.990,74.007,73.995,73.994,73.998,73.994,
73.995,73.990,74.004,74.000,74.007,74.000,73.996,73.983,74.002,73.998,73.997,
74.012,74.006,73.967,73.994,74.000,73.984,74.012,74.014,73.998,73.999,74.007,
74.000,73.984,74.005,73.998,73.996,73.994,74.012,73.986,74.005,74.007,74.006,
74.010,74.018,74.003,74.000,73.984,74.002,74.003,74.005,73.997,74.000,74.010,
74.013,74.020,74.003,73.988,74.001,74.009,74.005,73.996,74.004,73.999,73.990,
74.006,74.009,74.010,73.989,73.990,74.009,74.014,74.015,74.008,73.993,74.000,
74.010,73.982,73.984,73.995,74.017,74.013,74.012,74.015,74.030,73.986,74.000,
73.995,74.010,73.990,74.015,74.001,73.987,73.999,73.985,74.000,73.990,74.008,
74.010,74.003,73.991,74.006,74.003,74.000,74.001,73.986,73.997,73.994,74.003,
74.015,74.020,74.004,74.008,74.002,74.018,73.995,74.005,74.001,74.004,73.990,
73.996,73.998,74.015,74.000,74.016,74.025,74.000,74.030,74.005,74.000,74.016,
74.012,74.001,73.990,73.995,74.010,74.024,74.015,74.020,74.024,74.005,74.019,
74.035,74.010,74.012,74.015,74.026,74.017,74.013,74.036,74.025,74.026,74.010,
74.005,74.029,74.000,74.020)
dia<-qcc.groups(diametros,muestra);dia## [,1] [,2] [,3] [,4] [,5]
## 1 74.030 74.002 74.019 73.992 74.008
## 2 73.995 73.992 74.001 74.011 74.004
## 3 73.988 74.024 74.021 74.005 74.002
## 4 74.002 73.996 73.993 74.015 74.009
## 5 73.992 74.007 74.015 73.989 74.014
## 6 74.009 73.994 73.997 73.985 73.993
## 7 73.995 74.006 73.994 74.000 74.005
## 8 73.985 74.003 73.993 74.015 73.988
## 9 74.008 73.995 74.009 74.005 74.004
## 10 73.998 74.000 73.990 74.007 73.995
## 11 73.994 73.998 73.994 73.995 73.990
## 12 74.004 74.000 74.007 74.000 73.996
## 13 73.983 74.002 73.998 73.997 74.012
## 14 74.006 73.967 73.994 74.000 73.984
## 15 74.012 74.014 73.998 73.999 74.007
## 16 74.000 73.984 74.005 73.998 73.996
## 17 73.994 74.012 73.986 74.005 74.007
## 18 74.006 74.010 74.018 74.003 74.000
## 19 73.984 74.002 74.003 74.005 73.997
## 20 74.000 74.010 74.013 74.020 74.003
## 21 73.988 74.001 74.009 74.005 73.996
## 22 74.004 73.999 73.990 74.006 74.009
## 23 74.010 73.989 73.990 74.009 74.014
## 24 74.015 74.008 73.993 74.000 74.010
## 25 73.982 73.984 73.995 74.017 74.013
## 26 74.012 74.015 74.030 73.986 74.000
## 27 73.995 74.010 73.990 74.015 74.001
## 28 73.987 73.999 73.985 74.000 73.990
## 29 74.008 74.010 74.003 73.991 74.006
## 30 74.003 74.000 74.001 73.986 73.997
## 31 73.994 74.003 74.015 74.020 74.004
## 32 74.008 74.002 74.018 73.995 74.005
## 33 74.001 74.004 73.990 73.996 73.998
## 34 74.015 74.000 74.016 74.025 74.000
## 35 74.030 74.005 74.000 74.016 74.012
## 36 74.001 73.990 73.995 74.010 74.024
## 37 74.015 74.020 74.024 74.005 74.019
## 38 74.035 74.010 74.012 74.015 74.026
## 39 74.017 74.013 74.036 74.025 74.026
## 40 74.010 74.005 74.029 74.000 74.020xrango<-qcc(dia[1:25,], type="R")
La carta R nos permite identificar el rango, con esta carta se detectarán cambios en la amplitud o magnitud de la variación del proceso.
xbarra <- qcc(dia[1:25,], type="xbar")
summary(xbarra)##
## Call:
## qcc(data = dia[1:25, ], type = "xbar")
##
## xbar chart for dia[1:25, ]
##
## Summary of group statistics:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 73.99020 73.99820 74.00080 74.00118 74.00420 74.01020
##
## Group sample size: 5
## Number of groups: 25
## Center of group statistics: 74.00118
## Standard deviation: 0.009785039
##
## Control limits:
## LCL UCL
## 73.98805 74.0143La carta xbar nos permite monitorear la media y la variación de un proceso cuando se tienen datos continuos.
xdes<-qcc(dia[1:25,], type="S")
summary(xdes)##
## Call:
## qcc(data = dia[1:25, ], type = "S")
##
## S chart for dia[1:25, ]
##
## Summary of group statistics:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.002863564 0.007314369 0.008467585 0.009240037 0.011928956 0.016177144
##
## Group sample size: 5
## Number of groups: 25
## Center of group statistics: 0.009240037
## Standard deviation: 0.009829977
##
## Control limits:
## LCL UCL
## 0 0.01930242La carta S permite monitorear la variación (desviación estándar) del proceso cuando tenga datos continuos.
Capacidad de proceso
La capacidad del proceso se utiliza también según la ISO 15504 trata de las bases del management y de la definición de procesos en una organización.
La capacidad del proceso puede subdividirse en: 1) Medición la variabilidad del proceso y 2) Contrastar la variabilidad medida con una tolerancia o especificación predefinida.
process.capability(xbarra, spec.limits=c(73.95,74.05),confidence.level = 0.95)
##
## Process Capability Analysis
##
## Call:
## process.capability(object = xbarra, spec.limits = c(73.95, 74.05), confidence.level = 0.95)
##
## Number of obs = 125 Target = 74
## Center = 74 LSL = 73.95
## StdDev = 0.009785 USL = 74.05
##
## Capability indices:
##
## Value 2.5% 97.5%
## Cp 1.703 1.491 1.915
## Cp_l 1.743 1.555 1.932
## Cp_u 1.663 1.483 1.844
## Cp_k 1.663 1.448 1.878
## Cpm 1.691 1.480 1.902
##
## Exp<LSL 0% Obs<LSL 0%
## Exp>USL 0% Obs>USL 0%Además, el analisis de capacidad de proceso nos provee una matriz de índices de capacidad y los límites de confianza correspondientes.
Monitoreo
qcc(dia[1:25,], type="xbar", newdata=dia[26:40,], nsigmas=2)
## List of 15
## $ call : language qcc(data = dia[1:25, ], type = "xbar", newdata = dia[26:40, ], nsigmas = 2)
## $ type : chr "xbar"
## $ data.name : chr "dia[1:25, ]"
## $ data : num [1:25, 1:5] 74 74 74 74 74 ...
## ..- attr(*, "dimnames")=List of 2
## $ statistics : Named num [1:25] 74 74 74 74 74 ...
## ..- attr(*, "names")= chr [1:25] "1" "2" "3" "4" ...
## $ sizes : Named int [1:25] 5 5 5 5 5 5 5 5 5 5 ...
## ..- attr(*, "names")= chr [1:25] "1" "2" "3" "4" ...
## $ center : num 74
## $ std.dev : num 0.00979
## $ newstats : Named num [1:15] 74 74 74 74 74 ...
## ..- attr(*, "names")= chr [1:15] "26" "27" "28" "29" ...
## $ newdata : num [1:15, 1:5] 74 74 74 74 74 ...
## ..- attr(*, "dimnames")=List of 2
## $ newsizes : Named int [1:15] 5 5 5 5 5 5 5 5 5 5 ...
## ..- attr(*, "names")= chr [1:15] "26" "27" "28" "29" ...
## $ newdata.name: chr "dia[26:40, ]"
## $ nsigmas : num 2
## $ limits : num [1, 1:2] 74 74
## ..- attr(*, "dimnames")=List of 2
## $ violations :List of 2
## - attr(*, "class")= chr "qcc"En la anterior carta xbar se puede evidenciar que hay 9 grupos de muestra que estan por fuera de los limites establecidos. Recordando que la carta xbar mide la media y la variación de un proceso cuando se tienen datos continuos, el proceso no esta bajo control.
qcc(dia[1:25,], type="R", newdata=dia[26:40,])
## List of 15
## $ call : language qcc(data = dia[1:25, ], type = "R", newdata = dia[26:40, ])
## $ type : chr "R"
## $ data.name : chr "dia[1:25, ]"
## $ data : num [1:25, 1:5] 74 74 74 74 74 ...
## ..- attr(*, "dimnames")=List of 2
## $ statistics : Named num [1:25] 0.038 0.019 0.036 0.022 0.026 ...
## ..- attr(*, "names")= chr [1:25] "1" "2" "3" "4" ...
## $ sizes : Named int [1:25] 5 5 5 5 5 5 5 5 5 5 ...
## ..- attr(*, "names")= chr [1:25] "1" "2" "3" "4" ...
## $ center : num 0.0228
## $ std.dev : num 0.00979
## $ newstats : Named num [1:15] 0.044 0.025 0.015 0.019 0.017 ...
## ..- attr(*, "names")= chr [1:15] "26" "27" "28" "29" ...
## $ newdata : num [1:15, 1:5] 74 74 74 74 74 ...
## ..- attr(*, "dimnames")=List of 2
## $ newsizes : Named int [1:15] 5 5 5 5 5 5 5 5 5 5 ...
## ..- attr(*, "names")= chr [1:15] "26" "27" "28" "29" ...
## $ newdata.name: chr "dia[26:40, ]"
## $ nsigmas : num 3
## $ limits : num [1, 1:2] 0 0.0481
## ..- attr(*, "dimnames")=List of 2
## $ violations :List of 2
## - attr(*, "class")= chr "qcc"Para la carta R y la carta S los datos de nuestras muestras se encuentran bajo control, dentro de los limites.
qcc(dia[1:25,], type="S", newdata=dia[26:40,])
## List of 15
## $ call : language qcc(data = dia[1:25, ], type = "S", newdata = dia[26:40, ])
## $ type : chr "S"
## $ data.name : chr "dia[1:25, ]"
## $ data : num [1:25, 1:5] 74 74 74 74 74 ...
## ..- attr(*, "dimnames")=List of 2
## $ statistics : Named num [1:25] 0.01477 0.0075 0.01475 0.00908 0.01222 ...
## ..- attr(*, "names")= chr [1:25] "1" "2" "3" "4" ...
## $ sizes : Named int [1:25] 5 5 5 5 5 5 5 5 5 5 ...
## ..- attr(*, "names")= chr [1:25] "1" "2" "3" "4" ...
## $ center : num 0.00924
## $ std.dev : num 0.00983
## $ newstats : Named num [1:15] 0.01655 0.01033 0.00691 0.0075 0.00673 ...
## ..- attr(*, "names")= chr [1:15] "26" "27" "28" "29" ...
## $ newdata : num [1:15, 1:5] 74 74 74 74 74 ...
## ..- attr(*, "dimnames")=List of 2
## $ newsizes : Named int [1:15] 5 5 5 5 5 5 5 5 5 5 ...
## ..- attr(*, "names")= chr [1:15] "26" "27" "28" "29" ...
## $ newdata.name: chr "dia[26:40, ]"
## $ nsigmas : num 3
## $ limits : num [1, 1:2] 0 0.0193
## ..- attr(*, "dimnames")=List of 2
## $ violations :List of 2
## - attr(*, "class")= chr "qcc"Función de operación característica
La curva CO se construye a partir de la grafica del riesgo Beta contra la magitud del cambio que se desee detectar, expresado en unidades de desviacion estandar para varios tamaños muestrales n. Así, poder evaluar las probabilidades.
beta1 <- oc.curves.xbar(qcc(dia, type="xbar", nsigmas=3, plot=TRUE))
print(round(beta1, digits=4))## sample size
## shift (std.dev) n=5 n=1 n=10 n=15 n=20
## 0 0.9973 0.9973 0.9973 0.9973 0.9973
## 0.05 0.9971 0.9973 0.9970 0.9968 0.9966
## 0.1 0.9966 0.9972 0.9959 0.9952 0.9944
## 0.15 0.9957 0.9970 0.9940 0.9920 0.9900
## 0.2 0.9944 0.9968 0.9909 0.9869 0.9823
## 0.25 0.9925 0.9964 0.9864 0.9789 0.9701
## 0.3 0.9900 0.9960 0.9798 0.9670 0.9514
## 0.35 0.9866 0.9956 0.9708 0.9500 0.9243
## 0.4 0.9823 0.9950 0.9586 0.9266 0.8871
## 0.45 0.9769 0.9943 0.9426 0.8957 0.8383
## 0.5 0.9701 0.9936 0.9220 0.8562 0.7775
## 0.55 0.9616 0.9927 0.8963 0.8078 0.7055
## 0.6 0.9514 0.9916 0.8649 0.7505 0.6243
## 0.65 0.9390 0.9905 0.8275 0.6853 0.5371
## 0.7 0.9243 0.9892 0.7842 0.6137 0.4481
## 0.75 0.9071 0.9877 0.7351 0.5379 0.3616
## 0.8 0.8871 0.9860 0.6809 0.4608 0.2817
## 0.85 0.8642 0.9842 0.6225 0.3851 0.2115
## 0.9 0.8383 0.9821 0.5612 0.3136 0.1527
## 0.95 0.8094 0.9798 0.4983 0.2485 0.1059
## 1 0.7775 0.9772 0.4355 0.1913 0.0705
## 1.05 0.7428 0.9744 0.3743 0.1431 0.0450
## 1.1 0.7055 0.9713 0.3161 0.1038 0.0275
## 1.15 0.6659 0.9678 0.2622 0.0730 0.0161
## 1.2 0.6243 0.9641 0.2134 0.0497 0.0090
## 1.25 0.5812 0.9599 0.1703 0.0328 0.0048
## 1.3 0.5371 0.9554 0.1333 0.0209 0.0024
## 1.35 0.4925 0.9505 0.1022 0.0129 0.0012
## 1.4 0.4481 0.9452 0.0768 0.0077 0.0006
## 1.45 0.4043 0.9394 0.0564 0.0045 0.0002
## 1.5 0.3616 0.9332 0.0406 0.0025 0.0001
## 1.55 0.3206 0.9265 0.0286 0.0013 0.0000
## 1.6 0.2817 0.9192 0.0197 0.0007 0.0000
## 1.65 0.2453 0.9115 0.0133 0.0003 0.0000
## 1.7 0.2115 0.9032 0.0088 0.0002 0.0000
## 1.75 0.1806 0.8943 0.0056 0.0001 0.0000
## 1.8 0.1527 0.8849 0.0036 0.0000 0.0000
## 1.85 0.1278 0.8749 0.0022 0.0000 0.0000
## 1.9 0.1059 0.8643 0.0013 0.0000 0.0000
## 1.95 0.0869 0.8531 0.0008 0.0000 0.0000
## 2 0.0705 0.8413 0.0004 0.0000 0.0000
## 2.05 0.0566 0.8289 0.0002 0.0000 0.0000
## 2.1 0.0450 0.8159 0.0001 0.0000 0.0000
## 2.15 0.0353 0.8023 0.0001 0.0000 0.0000
## 2.2 0.0275 0.7881 0.0000 0.0000 0.0000
## 2.25 0.0211 0.7734 0.0000 0.0000 0.0000
## 2.3 0.0161 0.7580 0.0000 0.0000 0.0000
## 2.35 0.0121 0.7422 0.0000 0.0000 0.0000
## 2.4 0.0090 0.7257 0.0000 0.0000 0.0000
## 2.45 0.0066 0.7088 0.0000 0.0000 0.0000
## 2.5 0.0048 0.6915 0.0000 0.0000 0.0000
## 2.55 0.0034 0.6736 0.0000 0.0000 0.0000
## 2.6 0.0024 0.6554 0.0000 0.0000 0.0000
## 2.65 0.0017 0.6368 0.0000 0.0000 0.0000
## 2.7 0.0012 0.6179 0.0000 0.0000 0.0000
## 2.75 0.0008 0.5987 0.0000 0.0000 0.0000
## 2.8 0.0006 0.5793 0.0000 0.0000 0.0000
## 2.85 0.0004 0.5596 0.0000 0.0000 0.0000
## 2.9 0.0002 0.5398 0.0000 0.0000 0.0000
## 2.95 0.0002 0.5199 0.0000 0.0000 0.0000
## 3 0.0001 0.5000 0.0000 0.0000 0.0000
## 3.05 0.0001 0.4801 0.0000 0.0000 0.0000
## 3.1 0.0000 0.4602 0.0000 0.0000 0.0000
## 3.15 0.0000 0.4404 0.0000 0.0000 0.0000
## 3.2 0.0000 0.4207 0.0000 0.0000 0.0000
## 3.25 0.0000 0.4013 0.0000 0.0000 0.0000
## 3.3 0.0000 0.3821 0.0000 0.0000 0.0000
## 3.35 0.0000 0.3632 0.0000 0.0000 0.0000
## 3.4 0.0000 0.3446 0.0000 0.0000 0.0000
## 3.45 0.0000 0.3264 0.0000 0.0000 0.0000
## 3.5 0.0000 0.3085 0.0000 0.0000 0.0000
## 3.55 0.0000 0.2912 0.0000 0.0000 0.0000
## 3.6 0.0000 0.2743 0.0000 0.0000 0.0000
## 3.65 0.0000 0.2578 0.0000 0.0000 0.0000
## 3.7 0.0000 0.2420 0.0000 0.0000 0.0000
## 3.75 0.0000 0.2266 0.0000 0.0000 0.0000
## 3.8 0.0000 0.2119 0.0000 0.0000 0.0000
## 3.85 0.0000 0.1977 0.0000 0.0000 0.0000
## 3.9 0.0000 0.1841 0.0000 0.0000 0.0000
## 3.95 0.0000 0.1711 0.0000 0.0000 0.0000
## 4 0.0000 0.1587 0.0000 0.0000 0.0000
## 4.05 0.0000 0.1469 0.0000 0.0000 0.0000
## 4.1 0.0000 0.1357 0.0000 0.0000 0.0000
## 4.15 0.0000 0.1251 0.0000 0.0000 0.0000
## 4.2 0.0000 0.1151 0.0000 0.0000 0.0000
## 4.25 0.0000 0.1056 0.0000 0.0000 0.0000
## 4.3 0.0000 0.0968 0.0000 0.0000 0.0000
## 4.35 0.0000 0.0885 0.0000 0.0000 0.0000
## 4.4 0.0000 0.0808 0.0000 0.0000 0.0000
## 4.45 0.0000 0.0735 0.0000 0.0000 0.0000
## 4.5 0.0000 0.0668 0.0000 0.0000 0.0000
## 4.55 0.0000 0.0606 0.0000 0.0000 0.0000
## 4.6 0.0000 0.0548 0.0000 0.0000 0.0000
## 4.65 0.0000 0.0495 0.0000 0.0000 0.0000
## 4.7 0.0000 0.0446 0.0000 0.0000 0.0000
## 4.75 0.0000 0.0401 0.0000 0.0000 0.0000
## 4.8 0.0000 0.0359 0.0000 0.0000 0.0000
## 4.85 0.0000 0.0322 0.0000 0.0000 0.0000
## 4.9 0.0000 0.0287 0.0000 0.0000 0.0000
## 4.95 0.0000 0.0256 0.0000 0.0000 0.0000
## 5 0.0000 0.0228 0.0000 0.0000 0.0000Ahora analizaremos el proceso para tamaños de muestra variable
muestra2<-c(rep(1,5),rep(2,3),rep(3:5,each=5,length=15),rep(6:7,each=4,length=8),
rep(8,5),rep(9,4),rep(10:12,each=5,length=15),rep(13,3),rep(14,5),rep(15,3),
rep(16,5),rep(17,4),rep(18:19,each=5,length=10),rep(20,3),rep(21:25,each=5,length=25))
muestra2## [1] 1 1 1 1 1 2 2 2 3 3 3 3 3 4 4 4 4 4 5 5 5 5 5 6 6
## [26] 6 6 7 7 7 7 8 8 8 8 8 9 9 9 9 10 10 10 10 10 11 11 11 11 11
## [51] 12 12 12 12 12 13 13 13 14 14 14 14 14 15 15 15 16 16 16 16 16 17 17 17 17
## [76] 18 18 18 18 18 19 19 19 19 19 20 20 20 21 21 21 21 21 22 22 22 22 22 23 23
## [101] 23 23 23 24 24 24 24 24 25 25 25 25 25diametro2<-c(74.030,74.002,74.019,73.992,74.008,73.995,73.992,74.001,
73.988,74.024,74.021,74.005,74.002,74.002,73.996,73.993,74.015,74.009,
73.992,74.007,74.015,73.989,74.014,74.009,73.994,73.997,73.985,
73.995,74.006,73.994,74.000,73.985,74.003,73.993,74.015,73.988,
74.008,73.995,74.009,74.005,73.998,74.000,73.990,74.007,73.995,
73.994,73.998,73.994,73.995,73.990,74.004,74.000,74.007,74.000,73.996,
73.983,74.002,73.998,74.006,73.967,73.994,74.000,73.984,74.012,74.014,73.998,
74.000, 73.984,74.005,73.998,73.996,73.994,74.012,73.986,74.005,
74.006,74.010,74.018,74.003,74.000,73.984,74.002,74.003,74.005,73.997,
74.000,74.010,74.013,73.988,74.001,74.009,74.005,73.996,74.004,73.999,73.990,74.006,74.009,
74.010,73.989,73.990,74.009,74.014,74.015,74.008,73.993,74.000,74.010,
73.982,73.984,73.995,74.017,74.013)
diame<-qcc.groups(diametro2,muestra2)
diame## [,1] [,2] [,3] [,4] [,5]
## 1 74.030 74.002 74.019 73.992 74.008
## 2 73.995 73.992 74.001 NA NA
## 3 73.988 74.024 74.021 74.005 74.002
## 4 74.002 73.996 73.993 74.015 74.009
## 5 73.992 74.007 74.015 73.989 74.014
## 6 74.009 73.994 73.997 73.985 NA
## 7 73.995 74.006 73.994 74.000 NA
## 8 73.985 74.003 73.993 74.015 73.988
## 9 74.008 73.995 74.009 74.005 NA
## 10 73.998 74.000 73.990 74.007 73.995
## 11 73.994 73.998 73.994 73.995 73.990
## 12 74.004 74.000 74.007 74.000 73.996
## 13 73.983 74.002 73.998 NA NA
## 14 74.006 73.967 73.994 74.000 73.984
## 15 74.012 74.014 73.998 NA NA
## 16 74.000 73.984 74.005 73.998 73.996
## 17 73.994 74.012 73.986 74.005 NA
## 18 74.006 74.010 74.018 74.003 74.000
## 19 73.984 74.002 74.003 74.005 73.997
## 20 74.000 74.010 74.013 NA NA
## 21 73.988 74.001 74.009 74.005 73.996
## 22 74.004 73.999 73.990 74.006 74.009
## 23 74.010 73.989 73.990 74.009 74.014
## 24 74.015 74.008 73.993 74.000 74.010
## 25 73.982 73.984 73.995 74.017 74.013xbarra1 <- qcc(diame[1:25,], type="xbar")
Ahora la carta XBar nos permite establecer limites por intervalos
correpondientes a la tendencia de los datos esto nos permite tener un
ajuste personalizado para controlar el proceso.
xrango1<-qcc(diame[1:25,], type="R")
La carta R tambien genera intervalos en el UCL aunque conserva su LCL en
o constante.
xdes1<-qcc(diame[1:25,], type="S")
La carta S de desviacion estandar esta bajo control.
process.capability(xbarra1, spec.limits=c(73.95,74.05),confidence.level = 0.95)
##
## Process Capability Analysis
##
## Call:
## process.capability(object = xbarra1, spec.limits = c(73.95, 74.05), confidence.level = 0.95)
##
## Number of obs = 113 Target = 74
## Center = 74 LSL = 73.95
## StdDev = 0.009857 USL = 74.05
##
## Capability indices:
##
## Value 2.5% 97.5%
## Cp 1.691 1.470 1.912
## Cp_l 1.716 1.521 1.912
## Cp_u 1.665 1.475 1.856
## Cp_k 1.665 1.439 1.892
## Cpm 1.686 1.466 1.906
##
## Exp<LSL 0% Obs<LSL 0%
## Exp>USL 0% Obs>USL 0%?? process.capabilityObservaciones individuales
x <- c(33.75, 33.05, 34, 33.81, 33.46, 34.02, 33.68, 33.27, 33.49, 33.20,
33.62, 33.00, 33.54, 33.12, 33.84)
uno<-qcc(x, type="xbar.one")
Para las observaciones individuales se tiene la carta XBar bajo control
incluso se podria ajustar los limites para precisar la variabilidad.
process.capability(uno, spec.limits=c(32,34),confidence.level = 0.95)
##
## Process Capability Analysis
##
## Call:
## process.capability(object = uno, spec.limits = c(32, 34), confidence.level = 0.95)
##
## Number of obs = 15 Target = 33
## Center = 33.52 LSL = 32
## StdDev = 0.4262 USL = 34
##
## Capability indices:
##
## Value 2.5% 97.5%
## Cp 0.7822 0.4960 1.0684
## Cp_l 1.1915 0.7950 1.5880
## Cp_u 0.3728 0.1899 0.5558
## Cp_k 0.3728 0.1548 0.5908
## Cpm 0.4939 0.2747 0.7137
##
## Exp<LSL 0.018% Obs<LSL 0%
## Exp>USL 13% Obs>USL 6.7%Evidenciamos en la grafica anterior un problema ya que los datos parecen ser precisos pero inexactos.
Grafico P y NP
nn<-rep(50,30)
dis<-c(12,15,8,10,4,7,16,9,14,10,5,6,17,12,22,8,10,5,13,
11,20,18,24,15,9,12,7,13,9,6)
grap<-qcc(dis,type="p",sizes=nn,rules = shewhart.rules)
El grafico P nos permite identificar defectos. Ademas, hay dos muestras
que sobrepasan el limite de control superior.
prop1<-c(dis/nn)
plot(prop1,pch=16,type="o")
Identificamos la serie
data.frame(nn,dis,prop1)summary(grap)##
## Call:
## qcc(data = dis, type = "p", sizes = nn, rules = shewhart.rules)
##
## p chart for dis
##
## Summary of group statistics:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.0800000 0.1600000 0.2100000 0.2313333 0.2950000 0.4800000
##
## Group sample size: 50
## Number of groups: 30
## Center of group statistics: 0.2313333
## Standard deviation: 0.421685
##
## Control limits:
## LCL UCL
## 0.05242755 0.4102391
## 0.05242755 0.4102391
## ...
## 0.05242755 0.4102391granp<-qcc(dis,type="np",sizes=nn,rules = shewhart.rules)
summary(granp)##
## Call:
## qcc(data = dis, type = "np", sizes = nn, rules = shewhart.rules)
##
## np chart for dis
##
## Summary of group statistics:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 4.00000 8.00000 10.50000 11.56667 14.75000 24.00000
##
## Group sample size: 50
## Number of groups: 30
## Center of group statistics: 11.56667
## Standard deviation: 2.981763
##
## Control limits:
## LCL UCL
## 2.621377 20.51196La carta NP tambien nos muestra dos defectos que superan el UCL. Miremos la curva operativa del proceso.
beta3 <- oc.curves(qcc(dis, sizes=nn, type="p", plot=TRUE))
## Warning in oc.curves.p(object, ...): Some computed values for the type II error
## have been rounded due to the discreteness of the binomial distribution. Thus,
## some ARL values might be meaningless.
Grafico P
nn2<-rep(50,28)
dis2<-c(12,15,8,10,4,7,16,9,14,10,5,6,17,12,8,10,5,13,
11,20,18,15,9,12,7,13,9,6)
grap3<-qcc(dis2,type="p",sizes=nn2,rules = shewhart.rules)
summary(grap3)##
## Call:
## qcc(data = dis2, type = "p", sizes = nn2, rules = shewhart.rules)
##
## p chart for dis2
##
## Summary of group statistics:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.080 0.155 0.200 0.215 0.265 0.400
##
## Group sample size: 50
## Number of groups: 28
## Center of group statistics: 0.215
## Standard deviation: 0.4108223
##
## Control limits:
## LCL UCL
## 0.04070284 0.3892972
## 0.04070284 0.3892972
## ...
## 0.04070284 0.3892972granp4<-qcc(dis2,type="np",sizes=nn2,rules = shewhart.rules)
summary(granp4)##
## Call:
## qcc(data = dis2, type = "np", sizes = nn2, rules = shewhart.rules)
##
## np chart for dis2
##
## Summary of group statistics:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 4.00 7.75 10.00 10.75 13.25 20.00
##
## Group sample size: 50
## Number of groups: 28
## Center of group statistics: 10.75
## Standard deviation: 2.904953
##
## Control limits:
## LCL UCL
## 2.035142 19.46486Monitoreo
nn3<-rep(50,54);nn3## [1] 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50
## [26] 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50 50
## [51] 50 50 50 50dis3<-c(12,15,8,10,4,7,16,9,14,10,5,6,17,12,22,8,10,5,13,
11,20,18,24,15,9,12,7,13,9,6,9,6,12,5,6,4,6,3,7,6,2,4,3,6,5,4,8,5,6,7,5,6,3,5)
nn4<-nn3[1:30]
nn5<-nn3[31:54]
prueba<-dis3[1:30]
moni<-dis3[31:54]
q1<-qcc(prueba,sizes=nn4, type="p")
summary(q1)##
## Call:
## qcc(data = prueba, type = "p", sizes = nn4)
##
## p chart for prueba
##
## Summary of group statistics:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.0800000 0.1600000 0.2100000 0.2313333 0.2950000 0.4800000
##
## Group sample size: 50
## Number of groups: 30
## Center of group statistics: 0.2313333
## Standard deviation: 0.421685
##
## Control limits:
## LCL UCL
## 0.05242755 0.4102391
## 0.05242755 0.4102391
## ...
## 0.05242755 0.4102391q2<-qcc(moni,sizes=nn5, type="p")
summary(q2)##
## Call:
## qcc(data = moni, type = "p", sizes = nn5)
##
## p chart for moni
##
## Summary of group statistics:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.0400000 0.0800000 0.1100000 0.1108333 0.1200000 0.2400000
##
## Group sample size: 50
## Number of groups: 24
## Center of group statistics: 0.1108333
## Standard deviation: 0.3139256
##
## Control limits:
## LCL UCL
## 0 0.2440207
## 0 0.2440207
## ...
## 0 0.2440207qcc(prueba,sizes=nn4, type="p", newdata=moni,newsizes=nn5,ylim=c(0,0.5))
## List of 15
## $ call : language qcc(data = prueba, type = "p", sizes = nn4, newdata = moni, newsizes = nn5, ylim = c(0, 0.5))
## $ type : chr "p"
## $ data.name : chr "prueba"
## $ data : num [1:30, 1] 12 15 8 10 4 7 16 9 14 10 ...
## ..- attr(*, "dimnames")=List of 2
## $ statistics : Named num [1:30] 0.24 0.3 0.16 0.2 0.08 0.14 0.32 0.18 0.28 0.2 ...
## ..- attr(*, "names")= chr [1:30] "1" "2" "3" "4" ...
## $ sizes : num [1:30] 50 50 50 50 50 50 50 50 50 50 ...
## $ center : num 0.231
## $ std.dev : num 0.422
## $ newstats : Named num [1:24] 0.18 0.12 0.24 0.1 0.12 0.08 0.12 0.06 0.14 0.12 ...
## ..- attr(*, "names")= chr [1:24] "31" "32" "33" "34" ...
## $ newdata : num [1:24, 1] 9 6 12 5 6 4 6 3 7 6 ...
## $ newsizes : num [1:24] 50 50 50 50 50 50 50 50 50 50 ...
## $ newdata.name: chr "moni"
## $ nsigmas : num 3
## $ limits : num [1:54, 1:2] 0.0524 0.0524 0.0524 0.0524 0.0524 ...
## ..- attr(*, "dimnames")=List of 2
## $ violations :List of 2
## - attr(*, "class")= chr "qcc"Tamaño de muestra variable
muest<-c(rep(100,1),rep(80,2),rep(100,1),rep(110,2),rep(100,2),rep(90,2),
rep(110,1),rep(120,3),rep(110,1),rep(80,3),rep(90,1),rep(100,4),rep(90,2) )
discon<-c(12,8,6,9,10,12,11,16,10,6,20,15,9,8,6,8,10,7,5,8,5,8,10,6,9)
q3<-qcc(discon,sizes=muest, type="p")
prop2<-c(discon/muest)
plot(prop2,pch=16,type="o")
data.frame(muest,discon,prop2)Tamaño de muestra promedio
n<-mean(muest)
muest2<-rep(n,25)
q4<-qcc(discon,sizes=muest2, type="p")
Carta de control estandarizada
muest<-c(rep(100,1),rep(80,2),rep(100,1),rep(110,2),rep(100,2),rep(90,2),
rep(110,1),rep(120,3),rep(110,1),rep(80,3),rep(90,1),rep(100,4),rep(90,2) )
discon<-c(12,8,6,9,10,12,11,16,10,6,20,15,9,8,6,8,10,7,5,8,5,8,10,6,9)
muest2<-rep(1,25)
n<-mean(muest)
pro<-c(discon/muest);pro## [1] 0.12000000 0.10000000 0.07500000 0.09000000 0.09090909 0.10909091
## [7] 0.11000000 0.16000000 0.11111111 0.06666667 0.18181818 0.12500000
## [13] 0.07500000 0.06666667 0.05454545 0.10000000 0.12500000 0.08750000
## [19] 0.05555556 0.08000000 0.05000000 0.08000000 0.10000000 0.06666667
## [25] 0.10000000p<-mean(discon/n);p## [1] 0.0955102nop<-1-p;nop## [1] 0.9044898sigma<-sqrt(p*nop/muest);sigma## [1] 0.02939184 0.03286107 0.03286107 0.02939184 0.02802402 0.02802402
## [7] 0.02939184 0.02939184 0.03098172 0.03098172 0.02802402 0.02683095
## [13] 0.02683095 0.02683095 0.02802402 0.03286107 0.03286107 0.03286107
## [19] 0.03098172 0.02939184 0.02939184 0.02939184 0.02939184 0.03098172
## [25] 0.03098172zeta<-(pro-p)/sigma;zeta## [1] 0.8332176 0.1366296 -0.6241490 -0.1874740 -0.1641846 0.4846095
## [7] 0.4929871 2.1941397 0.5035521 -0.9309858 3.0797861 1.0990961
## [13] -0.7644232 -1.0750098 -1.4617730 0.1366296 0.8974082 -0.2437597
## [19] -1.2896203 -0.5277045 -1.5483961 -0.5277045 0.1527566 -0.9309858
## [25] 0.1449176length(zeta)## [1] 25length(muest2)## [1] 25length(discon)## [1] 25plot(zeta,ylim=c(-3,3),type="b")
abline(h=0)
abline(h=-3)
abline(h=3)
Carta c
disconf<-c(21,24,16,12,15,5,28,20,31,25,20,24,16,19,10,17,13,22,18,39,30,24,16,19,17,15)
tamaño<-rep(100,26)
q6<-qcc(disconf,sizes=tamaño,type="c")
summary(q6)##
## Call:
## qcc(data = disconf, type = "c", sizes = tamaño)
##
## c chart for disconf
##
## Summary of group statistics:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 5.00000 16.00000 19.00000 19.84615 24.00000 39.00000
##
## Group sample size: 100
## Number of groups: 26
## Center of group statistics: 19.84615
## Standard deviation: 4.454902
##
## Control limits:
## LCL UCL
## 6.481447 33.21086beta4 <- oc.curves(qcc(disconf, sizes=tamaño, type="c", plot=TRUE))
## Warning in oc.curves.c(object, ...): Some computed values for the type II error
## have been rounded due to the discreteness of the Poisson distribution. Thus,
## some ARL values might be meaningless.
Monitoreo
disconf2<-c(21,24,16,12,15,5,28,20,31,25,20,24,16,19,10,17,13,22,18,39,30,24,16,19,17,15 ,16,18,12,15,24,21,28,20,25,19,18,21,16,22,19,12,14,9,16,21)
tamaño2<-rep(100,46)
tamaño3<-tamaño2[1:26]
tamaño4<-tamaño2[27:46]
disconf3<-disconf2[1:26]
disconf4<-disconf2[27:46]
c1<-qcc(disconf3,sizes=tamaño3,type="c")
c2<-qcc(disconf4,sizes=tamaño4,type="c")
c3<-qcc(disconf3,sizes=tamaño3, type="c", newdata=disconf4,newsizes=tamaño4)
Carta u
tama<-rep(5,20)
total<-c(10,12,8,14,10,16,11,7,10,15,9,5,7,11,12,6,8,10,7,5)
q10<-qcc(total,sizes=tama,type="u")
beta5 <- oc.curves(qcc(total, sizes=tama, type="u", plot=TRUE))
## Warning in oc.curves.c(object, ...): Some computed values for the type II error
## have been rounded due to the discreteness of the Poisson distribution. Thus,
## some ARL values might be meaningless.
Muestra variable
defec<-c(14,12,20,11,7,10,21,16,19,23)
mue<-c(10,8,13,10,9.5,10,12,10.5,12,12.5)
q11<-qcc(defec,sizes=mue,type="u")
Carta de control estandarizada
upro<-c(defec/mue);upro## [1] 1.4000000 1.5000000 1.5384615 1.1000000 0.7368421 1.0000000 1.7500000
## [8] 1.5238095 1.5833333 1.8400000ubarra<-c(sum(defec)/sum(mue));ubarra## [1] 1.423256zeta1<-(upro-ubarra)/(sqrt(ubarra/mue));zeta1## [1] -0.06164389 0.18194872 0.34818035 -0.85685012 -1.77339822 -1.12191886
## [7] 0.94876140 0.27311859 0.46481431 1.23504583plot(zeta1,type="o",ylim=c(-3,3))
abline(h=0,lty=2)
abline(h=-3,lty=2)
abline(h=3,lty=2)
Defectos bajos
tiempo<-c(286,948,536,124,816,729,4,143,431,8,2837,596,81,227,603,492,1199,1214,2831,96)
y<-tiempo^0.2777;y## [1] 4.809865 6.709029 5.726497 3.813671 6.435412 6.237053 1.469576 3.967682
## [9] 5.390069 1.781509 9.096180 5.897744 3.388335 4.510954 5.916898 5.591891
## [17] 7.161238 7.186005 9.090833 3.552031qcc(y, type="xbar.one")
## List of 11
## $ call : language qcc(data = y, type = "xbar.one")
## $ type : chr "xbar.one"
## $ data.name : chr "y"
## $ data : num [1:20, 1] 4.81 6.71 5.73 3.81 6.44 ...
## ..- attr(*, "dimnames")=List of 2
## $ statistics: Named num [1:20] 4.81 6.71 5.73 3.81 6.44 ...
## ..- attr(*, "names")= chr [1:20] "1" "2" "3" "4" ...
## $ sizes : int [1:20] 1 1 1 1 1 1 1 1 1 1 ...
## $ center : num 5.39
## $ std.dev : num 2.09
## $ nsigmas : num 3
## $ limits : num [1, 1:2] -0.888 11.661
## ..- attr(*, "dimnames")=List of 2
## $ violations:List of 2
## - attr(*, "class")= chr "qcc"Carta cusum
x1<-c(9.45,7.99,9.29,11.66,12.16,10.18,8.04,11.46,9.2,10.34,9.03,11.47,
10.51,9.4,10.08,9.37,10.62,10.31,8.52,10.84,10.9,9.33,12.29,11.5,
10.6,11.08,10.38,11.62,11.31,10.52)
cu <- cusum(x1, lambda=0.1, nsigmas=3)
summary(cu)##
## Call:
## cusum(data = x1, lambda = 0.1, nsigmas = 3)
##
## cusum chart for x1
##
## Summary of group statistics:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 7.990 9.377 10.445 10.315 11.252 12.290
##
## Group sample size: 1
## Number of groups: 30
## Center of group statistics: 10.315
## Standard deviation: 1.199865
##
## Decision interval (std.err.): 5
## Shift detection (std. err.): 1x11<-x1[1:20]
x12<-x1[21:30]
cu1 <- cusum(x11, lambda=0.1, nsigmas=3,center=10)
x12<-x1[21:30]
cu2 <- cusum(x12, lambda=0.1, nsigmas=3,center=11)
cu3<-cusum(x11, newdata=x12,nsigmas=3,lambda=0.1)
Carta ewma
x2<-c(9.45,7.99,9.29,11.66,12.16,10.18,8.04,11.46,9.2,10.34,9.03,11.47,
10.51,9.4,10.08,9.37,10.62,10.31,8.52,10.84,10.9,9.33,12.29,11.5,
10.6,11.08,10.38,11.62,11.31,10.52)
ew <- ewma(x2, lambda=0.1, nsigmas=3,center=10)
summary(cu)##
## Call:
## cusum(data = x1, lambda = 0.1, nsigmas = 3)
##
## cusum chart for x1
##
## Summary of group statistics:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 7.990 9.377 10.445 10.315 11.252 12.290
##
## Group sample size: 1
## Number of groups: 30
## Center of group statistics: 10.315
## Standard deviation: 1.199865
##
## Decision interval (std.err.): 5
## Shift detection (std. err.): 1Carta Multivariada
n1<-rep(10,20)
resistencia<-matrix(c(115.25,115.91,115.05,116.21,115.9,115.55,114.98,115.25,116.15,115.92,115.75,
114.9,116.01,115.83,115.29,115.63,115.47,115.58,115.72,115.40))
diam<-matrix(c(1.04,1.06,1.09,1.05,1.07,1.06,1.05,1.10,1.09,1.05,0.99,1.06,1.05,1.07,
1.11,1.04,1.03,1.05,1.06,1.04))
X <- list(diam, resistencia)
carta <- mqcc(X, type = "T2",confidence.level = 0.999,sizes=n1)
summary(carta)##
## Call:
## mqcc(data = X, type = "T2", confidence.level = 0.999, sizes = n1)
##
## T2.single chart for X
##
## Summary of group statistics:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.013347 0.733726 1.274115 1.900000 2.931810 6.501636
##
## Number of variables: 2
## Number of groups: 20
## Group sample size: 1
##
## Center:
## X[1] X[2]
## 1.0580 115.5875
##
## Covariance matrix:
## X[1] X[2]
## X[1] 0.0007115789 -0.001468421
## X[2] -0.0014684211 0.147188158
## |S|: 0.0001025797
##
## Control limits:
## LCL UCL
## 0 10.04178ellipseChart(carta,confidence.level = 0.999)
ellipseChart(carta, show.id = TRUE)
Pruebas de precision y exactitud.
Observaciones individuales
y1=matrix(c(5.4,3.2,5.2,3.5,2.9,4.6,4.4,5,8.4,4.2,3.8,4.3,3.7,3.8,2.6,2.7,7.9,6.6,4,2.5
,3.8,2.8,2.9,3.3,7.2,7.3,7,6),ncol=1)
y2=matrix(c(93.6,92.6,91.7,86.9,90.4,92.1,91.5,90.3,85.1,89.7,92.5,91.8,91.7,
90.3,94.5,94.5,88.7,84.6,90.7,90.2,92.7,91.5,91.8,90.6,87.3,79.0,82.6,83.5),ncol=1)
ca<-cov(y1,y2)
ca## [,1]
## [1,] -4.655767va=var(y1)
va## [,1]
## [1,] 3.019947y=list(y1=y1,y2=y2)
y## $y1
## [,1]
## [1,] 5.4
## [2,] 3.2
## [3,] 5.2
## [4,] 3.5
## [5,] 2.9
## [6,] 4.6
## [7,] 4.4
## [8,] 5.0
## [9,] 8.4
## [10,] 4.2
## [11,] 3.8
## [12,] 4.3
## [13,] 3.7
## [14,] 3.8
## [15,] 2.6
## [16,] 2.7
## [17,] 7.9
## [18,] 6.6
## [19,] 4.0
## [20,] 2.5
## [21,] 3.8
## [22,] 2.8
## [23,] 2.9
## [24,] 3.3
## [25,] 7.2
## [26,] 7.3
## [27,] 7.0
## [28,] 6.0
##
## $y2
## [,1]
## [1,] 93.6
## [2,] 92.6
## [3,] 91.7
## [4,] 86.9
## [5,] 90.4
## [6,] 92.1
## [7,] 91.5
## [8,] 90.3
## [9,] 85.1
## [10,] 89.7
## [11,] 92.5
## [12,] 91.8
## [13,] 91.7
## [14,] 90.3
## [15,] 94.5
## [16,] 94.5
## [17,] 88.7
## [18,] 84.6
## [19,] 90.7
## [20,] 90.2
## [21,] 92.7
## [22,] 91.5
## [23,] 91.8
## [24,] 90.6
## [25,] 87.3
## [26,] 79.0
## [27,] 82.6
## [28,] 83.5carta2 = mqcc(y, type = "T2.single", confidence.level = 0.999)
summary(carta2)##
## Call:
## mqcc(data = y, type = "T2.single", confidence.level = 0.999)
##
## T2.single chart for y
##
## Summary of group statistics:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.116039 0.508567 1.263033 1.928571 2.683548 8.543183
##
## Number of variables: 2
## Number of groups: 28
## Group sample size: 1
##
## Center:
## y1 y2
## 4.607143 89.728571
##
## Covariance matrix:
## y1 y2
## y1 3.019947 -4.655767
## y2 -4.655767 14.220635
## |S|: 21.2694
##
## Control limits:
## LCL UCL
## 0 11.05372ellipseChart(carta2)
Libreria qicharts
Esta Libreria nos permite crear las cartas de control en la cual lo mas recomendable es entender de manera detallada los argumentos de la funcion “qic()”
El autor de esta paqueteria recomienda dos libros de Montgomery’s Introduction to Statistical Process Control (Montgomery 2009). Y tambien, The Healthcare Data Guide (Provost 2011)
Cargamos las librerias
library(qicharts)
library(qicharts2)El autor sugiere que se bloquee el generador de números aleatorios para reproducir los gráficos de esta viñeta
set.seed(7)Cartas de Control Basicas
La mejor manera de ilustrar el manejo de estas cartas es comenzando con vector simple de numeros aleatorios.
Creamos el vector (y) por medio de la funcion rnorm() para 24 numeros aleatorios que siguen una distribucion normal
y <- rnorm(24)
y## [1] 2.287247161 -1.196771682 -0.694292510 -0.412292951 -0.970673341
## [6] -0.947279945 0.748139340 -0.116955226 0.152657626 2.189978107
## [11] 0.356986230 2.716751783 2.281451926 0.324020540 1.896067067
## [16] 0.467680511 -0.893800723 -0.307328300 -0.004822422 0.988164149
## [21] 0.839750360 0.705341831 1.305964721 -1.387996217Podemos recrear un histograma para conocer mejor nuestros datos
hist(y)
Generemos una primera carta de intervalos individuales
qic(y, chart = 'i')
En la carta anterior podemos observar que la muestra 9 se encuentra fuera del limite inferior por lo que hay que entrar en detalle que sucede.
Un experimento que podemos realizar es cambiar la muestra 9 qe identificar graficamente que pasa en la carta de control si esta muestra fuera un valor atipico.
y[9] <- 6Recreamos la carta
qic(y, chart = 'i')
Revisando la muestra 9 que anteriormente estaba fuera de control se modifica y corrige de modo que ahora la carta de muestras individuales nos permite ver todos los subgrupos dentro de los limites establecidos
Tipos de Cartas de Control
Los límites de control, también llamados límites sigma, generalmente se ubican a ±3 desviaciones estándar de la línea central. La desviación estándar es la desviación estándar estimada de la variación de causa común en el proceso de interés, que depende de la distribución teórica de los datos.
Para demostrar el uso de gráficos U y P para datos de conteo, crearemos un marco de datos que imite el número semanal de úlceras por presión adquiridas en un hospital que, en promedio, tiene 300 pacientes con una estadía promedio de cuatro días.
# Setup parameters
m.beds <- 300
m.stay <- 4
m.days <- m.beds * 7
m.discharges <- m.days / m.stay
p.pu <- 0.08
# Simulate data
discharges <- rpois(24, lambda = m.discharges)
patientdays <- round(rnorm(24, mean = m.days, sd = 100))
n.pu <- rpois(24, lambda = m.discharges * p.pu * 1.5)
n.pat.pu <- rbinom(24, size = discharges, prob = p.pu)
week <- seq(as.Date('2014-1-1'),
length.out = 24,
by = 'week')
# Combine data into a data frame
d <- data.frame(week, discharges, patientdays,n.pu, n.pat.pu)
d# C chart example:: Displaying the number of defects
qic(n.pu,
x = week,
data = d,
chart = 'c',
ylab = 'Count',
xlab = 'Week', title = 'Hospital acquired pressure ulcers (C chart)')
El gráfico U traza la tasa de defectos. Una tasa difiere de una proporción en que el numerador y el denominador no necesitan ser del mismo tipo y que el numerador puede exceder al denominador. Por ejemplo, la tasa de úlceras por presión se puede expresar como el número de úlceras por presión por 1000 días-paciente.
# U chart for rate of defects
## U charts displaying the rate of defects
qic(n.pu,
n = patientdays,
x = week,
data = d,
chart = 'u',
multiply = 1000,
title = 'Hospital acquired pressure ulcers (U chart)',
ylab = 'Count per 1000 patient days',
xlab = 'Week')
La gráfica P es probablemente la gráfica de control más común en el cuidado de la salud. Se utiliza para trazar la proporción (o porcentaje) de unidades defectuosas, por ejemplo, la proporción de pacientes con una o más úlceras por presión. Como se mencionó, los defectuosos se modelan mediante la distribución binomial.
# P chart for proportion of defective units
qic(n.pat.pu,
n = discharges,
x = week,
data = d,
chart = 'p',
multiply = 100,
title = 'Hospital acquired pressure ulcers (P chart)',
ylab = 'Percent patients',
xlab = 'Week')
d <- c(NA, rgeom(23, 0.08))
d## [1] NA 30 16 1 3 8 5 1 17 5 8 12 0 3 11 11 13 0 1 7 5 3 5 2Gráfico G para unidades producidas entre unidades defectuosas
# G chart for units produced between defective units
# Plot G chart
# G chart displaying the number of units produced between defectives
qic(d,
chart = 'g',
title = 'Patients between pressure ulcers (G chart)',
ylab = 'Count',
xlab = 'Discharge no.')
Ejercicio con nacimientos de bebes
Creamos el vector de pesos al nacer de 24 bebes
# Vector of birth weights from 24 babies
y <- round(rnorm(24, mean = 3400, sd = 400))
y## [1] 2634 2464 3593 3871 2883 3646 3502 3691 3930 3459 3161 4277 4331 3854 3324
## [16] 3590 3182 3822 3572 2672 3123 2627 3884 3288En el cuidado de la salud, que, como habrán adivinado, es mi dominio, la mayoría de los datos de calidad son datos de conteo.
I gráfico de pesos individuales al nacer
## I chart for individual measurements
qic(y,
chart = 'i',
title = 'Birth weight (I chart)',
ylab = 'Grams',
xlab = 'Baby no.')
Gráficos Xbar y S para mediciones promedio
# Vector of 24 subgroup sizes (average = 12)
sizes <- rpois(24, 12)
sizes## [1] 8 15 11 12 8 14 19 14 11 14 16 7 17 8 16 12 6 16 14 16 8 12 8 15Vector de fechas identificando subgrupos
date <- seq(as.Date('2015-1-1'), length.out = 24, by = 'day')
date <- rep(date, sizes)
date## [1] "2015-01-01" "2015-01-01" "2015-01-01" "2015-01-01" "2015-01-01"
## [6] "2015-01-01" "2015-01-01" "2015-01-01" "2015-01-02" "2015-01-02"
## [11] "2015-01-02" "2015-01-02" "2015-01-02" "2015-01-02" "2015-01-02"
## [16] "2015-01-02" "2015-01-02" "2015-01-02" "2015-01-02" "2015-01-02"
## [21] "2015-01-02" "2015-01-02" "2015-01-02" "2015-01-03" "2015-01-03"
## [26] "2015-01-03" "2015-01-03" "2015-01-03" "2015-01-03" "2015-01-03"
## [31] "2015-01-03" "2015-01-03" "2015-01-03" "2015-01-03" "2015-01-04"
## [36] "2015-01-04" "2015-01-04" "2015-01-04" "2015-01-04" "2015-01-04"
## [41] "2015-01-04" "2015-01-04" "2015-01-04" "2015-01-04" "2015-01-04"
## [46] "2015-01-04" "2015-01-05" "2015-01-05" "2015-01-05" "2015-01-05"
## [51] "2015-01-05" "2015-01-05" "2015-01-05" "2015-01-05" "2015-01-06"
## [56] "2015-01-06" "2015-01-06" "2015-01-06" "2015-01-06" "2015-01-06"
## [61] "2015-01-06" "2015-01-06" "2015-01-06" "2015-01-06" "2015-01-06"
## [66] "2015-01-06" "2015-01-06" "2015-01-06" "2015-01-07" "2015-01-07"
## [71] "2015-01-07" "2015-01-07" "2015-01-07" "2015-01-07" "2015-01-07"
## [76] "2015-01-07" "2015-01-07" "2015-01-07" "2015-01-07" "2015-01-07"
## [81] "2015-01-07" "2015-01-07" "2015-01-07" "2015-01-07" "2015-01-07"
## [86] "2015-01-07" "2015-01-07" "2015-01-08" "2015-01-08" "2015-01-08"
## [91] "2015-01-08" "2015-01-08" "2015-01-08" "2015-01-08" "2015-01-08"
## [96] "2015-01-08" "2015-01-08" "2015-01-08" "2015-01-08" "2015-01-08"
## [101] "2015-01-08" "2015-01-09" "2015-01-09" "2015-01-09" "2015-01-09"
## [106] "2015-01-09" "2015-01-09" "2015-01-09" "2015-01-09" "2015-01-09"
## [111] "2015-01-09" "2015-01-09" "2015-01-10" "2015-01-10" "2015-01-10"
## [116] "2015-01-10" "2015-01-10" "2015-01-10" "2015-01-10" "2015-01-10"
## [121] "2015-01-10" "2015-01-10" "2015-01-10" "2015-01-10" "2015-01-10"
## [126] "2015-01-10" "2015-01-11" "2015-01-11" "2015-01-11" "2015-01-11"
## [131] "2015-01-11" "2015-01-11" "2015-01-11" "2015-01-11" "2015-01-11"
## [136] "2015-01-11" "2015-01-11" "2015-01-11" "2015-01-11" "2015-01-11"
## [141] "2015-01-11" "2015-01-11" "2015-01-12" "2015-01-12" "2015-01-12"
## [146] "2015-01-12" "2015-01-12" "2015-01-12" "2015-01-12" "2015-01-13"
## [151] "2015-01-13" "2015-01-13" "2015-01-13" "2015-01-13" "2015-01-13"
## [156] "2015-01-13" "2015-01-13" "2015-01-13" "2015-01-13" "2015-01-13"
## [161] "2015-01-13" "2015-01-13" "2015-01-13" "2015-01-13" "2015-01-13"
## [166] "2015-01-13" "2015-01-14" "2015-01-14" "2015-01-14" "2015-01-14"
## [171] "2015-01-14" "2015-01-14" "2015-01-14" "2015-01-14" "2015-01-15"
## [176] "2015-01-15" "2015-01-15" "2015-01-15" "2015-01-15" "2015-01-15"
## [181] "2015-01-15" "2015-01-15" "2015-01-15" "2015-01-15" "2015-01-15"
## [186] "2015-01-15" "2015-01-15" "2015-01-15" "2015-01-15" "2015-01-15"
## [191] "2015-01-16" "2015-01-16" "2015-01-16" "2015-01-16" "2015-01-16"
## [196] "2015-01-16" "2015-01-16" "2015-01-16" "2015-01-16" "2015-01-16"
## [201] "2015-01-16" "2015-01-16" "2015-01-17" "2015-01-17" "2015-01-17"
## [206] "2015-01-17" "2015-01-17" "2015-01-17" "2015-01-18" "2015-01-18"
## [211] "2015-01-18" "2015-01-18" "2015-01-18" "2015-01-18" "2015-01-18"
## [216] "2015-01-18" "2015-01-18" "2015-01-18" "2015-01-18" "2015-01-18"
## [221] "2015-01-18" "2015-01-18" "2015-01-18" "2015-01-18" "2015-01-19"
## [226] "2015-01-19" "2015-01-19" "2015-01-19" "2015-01-19" "2015-01-19"
## [231] "2015-01-19" "2015-01-19" "2015-01-19" "2015-01-19" "2015-01-19"
## [236] "2015-01-19" "2015-01-19" "2015-01-19" "2015-01-20" "2015-01-20"
## [241] "2015-01-20" "2015-01-20" "2015-01-20" "2015-01-20" "2015-01-20"
## [246] "2015-01-20" "2015-01-20" "2015-01-20" "2015-01-20" "2015-01-20"
## [251] "2015-01-20" "2015-01-20" "2015-01-20" "2015-01-20" "2015-01-21"
## [256] "2015-01-21" "2015-01-21" "2015-01-21" "2015-01-21" "2015-01-21"
## [261] "2015-01-21" "2015-01-21" "2015-01-22" "2015-01-22" "2015-01-22"
## [266] "2015-01-22" "2015-01-22" "2015-01-22" "2015-01-22" "2015-01-22"
## [271] "2015-01-22" "2015-01-22" "2015-01-22" "2015-01-22" "2015-01-23"
## [276] "2015-01-23" "2015-01-23" "2015-01-23" "2015-01-23" "2015-01-23"
## [281] "2015-01-23" "2015-01-23" "2015-01-24" "2015-01-24" "2015-01-24"
## [286] "2015-01-24" "2015-01-24" "2015-01-24" "2015-01-24" "2015-01-24"
## [291] "2015-01-24" "2015-01-24" "2015-01-24" "2015-01-24" "2015-01-24"
## [296] "2015-01-24" "2015-01-24"Vector de pesos al nacer
y <- round(rnorm(sum(sizes), 3400, 400))
y## [1] 3589 3176 3897 3394 3083 3239 2641 3789 3194 3406 3296 4009 2811 3393 3410
## [16] 3399 3226 3238 3462 3011 4019 3252 4185 3156 3369 2668 3722 2809 2211 2864
## [31] 3294 3246 3159 3139 4103 3392 3462 3096 2780 4500 3819 3767 3588 3153 3417
## [46] 3039 3936 3722 3527 3324 2965 3458 4385 3769 3697 3966 3901 4244 3684 2810
## [61] 3164 3456 3195 3460 3577 3335 3789 3131 4055 2973 3395 2654 3407 3301 3032
## [76] 2531 3140 3610 3290 3422 3245 3233 2934 4095 3298 3011 3844 3789 3903 4111
## [91] 2327 3664 3872 3557 2924 3257 2814 2964 3137 4305 3435 3707 3155 3461 3163
## [106] 3016 3166 3663 3284 3762 3480 3379 3037 2943 3796 3445 3860 3036 2958 2746
## [121] 2753 3065 3837 3894 3469 3448 3623 3597 3372 2860 3720 3272 3257 3196 2648
## [136] 3019 4309 3481 2477 3377 3425 3684 3163 3519 3657 4245 3767 2771 3797 3592
## [151] 3281 3726 3000 3620 3512 3767 2707 2808 4292 3555 3664 3290 3510 2490 3763
## [166] 2965 3314 3107 3485 3024 3152 3498 3549 3651 2971 3117 3763 3272 3866 3151
## [181] 3899 3976 3705 3624 4040 3361 2820 3297 2587 3635 3464 3445 3629 3014 3527
## [196] 3331 3035 2661 3668 3356 4027 3062 3839 3520 3089 3385 3844 3615 3255 3358
## [211] 3534 3724 2727 3666 3083 4011 2805 3132 4070 3645 3307 3642 2936 2934 3052
## [226] 3296 3202 2878 4209 3098 3303 3839 3021 2946 3047 3607 3265 3391 3359 3520
## [241] 3723 3385 2817 3150 3332 3910 3298 3334 3229 3377 2822 4153 3447 3568 4031
## [256] 3299 3378 3391 4332 3360 3467 3292 3738 3964 2774 3468 2798 3798 3898 3385
## [271] 3235 3914 2953 3066 4000 3760 3217 3318 3165 3126 3802 3091 2603 3036 3175
## [286] 2913 2672 3240 4247 3966 3626 2967 3023 3302 3834 3623 2530Marco de datos de pesos y fechas de nacimiento
d <- data.frame(y, date)
head(d, 24)Grafica del gráfico Xbar de los pesos promedio al nacer por fecha de nacimiento Gráfico Xbar de medidas promedio
qic(y,
x = date,
data = d,
chart = 'xbar',
title = 'Average birth weight (Xbar chart)',
ylab = 'Grams',
xlab = 'Date')
Trazar el gráfico S de la desviación estándar dentro del subgrupo
Gráfica S de desviaciones estándar dentro de subgrupos
qic(y,
x = date,
data = d,
chart = 's',
title = 'Standard deviation of birth weight (S chart)',
ylab = 'Grams',
xlab = 'Date')
Gráfico T para el tiempo entre eventos Elija 24 fechas aleatorias y ordénelas
dates <- seq(as.Date('2015-1-1'), as.Date('2015-12-31'), by = 'day')
events <- sort(sample(dates, 24))Vector de tiempo (días) entre eventos
d <- c(NA, diff(events))
d## [1] NA 39 33 25 23 10 1 21 21 1 9 17 6 1 8 16 27 11 16 8 8 9 13 5Trazar gráfico T de días entre eventos
qic(d,
chart = 't',
title = 'Days between pressure ulcers (T chart)',
ylab = 'Days',
xlab = 'Pressure ulcer no.')
# Standardised control charts
# Rebuild data frame from figure 5
d <- data.frame(n.pat.pu, discharges, week)
# Plot standardised P chart
qic(n.pat.pu,
n = discharges,
x = week,
data = d,
chart = 'p',
title = 'Patients with hospital acquired pressure ulcers (Standardised P chart)',
ylab = 'Standard deviations',
xlab = 'Week')
#standardised = TrueCarta cusum para altura estudiantes curso CEC :: cusum chart for heigth
Creando el df
x1<-c(1.83,1.75,1.89,1.65,1.54,1.56,1.70,1.65,1.90,1.66,1.87,1.75,1.98,1.56,1.87,1.54,1.65,1.74,1.87,1.86,1.50,1.70,1.75)Ordenamos
x1_s <- sort(x1)
x1_s## [1] 1.50 1.54 1.54 1.56 1.56 1.65 1.65 1.65 1.66 1.70 1.70 1.74 1.75 1.75 1.75
## [16] 1.83 1.86 1.87 1.87 1.87 1.89 1.90 1.98Primera carta
cu <- cusum(x1, lambda=0.1, nsigmas=3,decision.interval = 1)
Analisis
summary(cu)##
## Call:
## cusum(data = x1, decision.interval = 1, lambda = 0.1, nsigmas = 3)
##
## cusum chart for x1
##
## Summary of group statistics:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1.500 1.650 1.740 1.729 1.865 1.980
##
## Group sample size: 1
## Number of groups: 23
## Center of group statistics: 1.72913
## Standard deviation: 0.1547389
##
## Decision interval (std.err.): 1
## Shift detection (std. err.): 1Separar primeros 10 datos
x11<-x1[1:10]
x11## [1] 1.83 1.75 1.89 1.65 1.54 1.56 1.70 1.65 1.90 1.66Separar siguientes 10
x12<-x1[11:20]
x12## [1] 1.87 1.75 1.98 1.56 1.87 1.54 1.65 1.74 1.87 1.86summary(x11)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1.540 1.650 1.680 1.713 1.810 1.900cu1 <- cusum(x11,lambda=30,
nsigmas=3,center=1.68, decision.interval = 1)
summary(x12)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1.540 1.673 1.805 1.769 1.870 1.980cu2 <- cusum(x12, nsigmas=3,center=1.805, decision.interval = 1)
cu3<-cusum(x11,newdata=x12,nsigmas=3,lambda=0.1,chart.all=TRUE, title = "Cusum Chart for x11 and x12", xlab="Groups", ylab="Cumulative Sum", col=heat.colors())
??cusum
Estadistica con R
summary(cu3)##
## Call:
## cusum(data = x11, newdata = x12, nsigmas = 3, lambda = 0.1, chart.all = TRUE, title = "Cusum Chart for x11 and x12", xlab = "Groups", ylab = "Cumulative Sum", col = heat.colors())
##
## cusum chart for x11
##
## Summary of group statistics:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1.540 1.650 1.680 1.713 1.810 1.900
##
## Group sample size: 1
## Number of groups: 10
## Center of group statistics: 1.713
## Standard deviation: 0.1250985
##
## Summary of group statistics in x12:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1.5400 1.6725 1.8050 1.7690 1.8700 1.9800
##
## Group sample size: 1
## Number of groups: 10
##
## Decision interval (std.err.): 5
## Shift detection (std. err.): 1cu3## List of 18
## $ call : language cusum(data = x11, newdata = x12, nsigmas = 3, lambda = 0.1, chart.all = TRUE, title = "Cusum Chart for x11 a| __truncated__ ...
## $ type : chr "cusum"
## $ data.name : chr "x11"
## $ data : num [1:10, 1] 1.83 1.75 1.89 1.65 1.54 1.56 1.7 1.65 1.9 1.66
## ..- attr(*, "dimnames")=List of 2
## $ statistics : Named num [1:10] 1.83 1.75 1.89 1.65 1.54 1.56 1.7 1.65 1.9 1.66
## ..- attr(*, "names")= chr [1:10] "1" "2" "3" "4" ...
## $ sizes : int [1:10] 1 1 1 1 1 1 1 1 1 1
## $ center : num 1.71
## $ std.dev : num 0.125
## $ newstats : Named num [1:10] 1.87 1.75 1.98 1.56 1.87 1.54 1.65 1.74 1.87 1.86
## ..- attr(*, "names")= chr [1:10] "11" "12" "13" "14" ...
## $ newdata : num [1:10, 1] 1.87 1.75 1.98 1.56 1.87 1.54 1.65 1.74 1.87 1.86
## $ newsizes : int [1:10] 1 1 1 1 1 1 1 1 1 1
## $ newdata.name : chr "x12"
## $ pos : num [1:20] 0.435 0.231 1.146 0.142 0 ...
## $ neg : num [1:20] 0 0 0 -0.0036 -0.8865 ...
## $ head.start : num 0
## $ decision.interval: num 5
## $ se.shift : num 1
## $ violations :List of 2
## - attr(*, "class")= chr "cusum.qcc"R y R
Ejercicio de Panadería
Para el cálculo del estudio Gage R&R completo.
La empresa Dulce Paladar fabrica deliciosos productos de panadería y varios tipos de Pan, El director de la compañía quiere empezar un proyecto Seis Sigma para mejorar la línea de producción de pan.
Ahora el sistema de medida ha de ser evaluado antes de comenzar otros análisis.
Hay 2 multiformadoras disponibles para alistar los productos y 3 tipos de mezclas para pan son seleccionadas al azar al final de la línea de producción. Se mide el peso de cada mezcla para pan con cada instrumento de medida 3 veces. Los datos son los siguientes:”
Ejemplo1
Multiformadora = factor(rep(1:2, each = 9))
Pan = factor(rep(rep(1:3, each = 3), 2))
run = factor(rep(1:3, 6))
Peso= c(99,100, 101, 98, 99, 100,100, 101, 102,
95, 90, 98, 97, 99, 105, 105, 103, 110)
Panes = data.frame(Multiformadora, Pan ,run, Peso)
ggplot(Panes,aes(Multiformadora,Peso))+geom_boxplot(aes(colour=Pan))
library(SixSigma)
#ss.rr(var, part, appr, data, main, sub)
my.rr <- ss.rr(var = Peso, part = Pan,
appr = Multiformadora,
data = Panes,
main = "Six Sigma Gage R&R Measure",
sub = "Multiformadoras de Pan")## Complete model (with interaction):
##
## Df Sum Sq Mean Sq F value Pr(>F)
## Pan 2 122.11 61.06 1.386 0.4191
## Multiformadora 1 0.22 0.22 0.005 0.9498
## Pan:Multiformadora 2 88.11 44.06 5.322 0.0221
## Repeatability 12 99.33 8.28
## Total 17 309.78
##
## alpha for removing interaction: 0.05
##
## Gage R&R
##
## VarComp %Contrib
## Total Gage R&R 20.203704 87.70
## Repeatability 8.277778 35.93
## Reproducibility 11.925926 51.77
## Multiformadora 0.000000 0.00
## Pan:Multiformadora 11.925926 51.77
## Part-To-Part 2.833333 12.30
## Total Variation 23.037037 100.00
##
## StdDev StudyVar %StudyVar
## Total Gage R&R 4.494853 26.96912 93.65
## Repeatability 2.877113 17.26268 59.94
## Reproducibility 3.453393 20.72036 71.95
## Multiformadora 0.000000 0.00000 0.00
## Pan:Multiformadora 3.453393 20.72036 71.95
## Part-To-Part 1.683251 10.09950 35.07
## Total Variation 4.799691 28.79815 100.00
##
## Number of Distinct Categories = 1## Warning in widths.x[pos.widths[[nm]]] <- widths.settings[[nm]] *
## widths.defaults[[nm]]$x: number of items to replace is not a multiple of
## replacement length
Ejemplo 2
Hay 2 instrumentos de medida disponibles para alistar la mezcla y 3 tipos de mezclas para pan son seleccionadas al azar al final de la línea de producción. Se mide el peso de cada mezcla para pan con cada instrumento de medida 3 veces. Los datos son los siguientes:”
InstrumentoMedida = factor(rep(1:2, each = 9))
Masa = factor(rep(rep(1:3, each = 3), 2))
run = factor(rep(1:3, 6))
Peso= c(4980,4950,4998,5050,5010,5090,4990,5030,5080,
5000,5005,5010,5000,5001,5003,5000,4999,4998)
Panes = data.frame(InstrumentoMedida, Masa ,run, Peso)
ggplot(Panes,aes(InstrumentoMedida,Peso))+geom_boxplot(aes(colour=Masa))
library(SixSigma)
#ss.rr(var, part, appr, data, main, sub)
my.rr <- ss.rr(var = Peso, part = Masa,
appr = InstrumentoMedida,
data = Panes,
main = "Six Sigma Gage R&R Measure",
sub = "Alistamiento Mezcla de Masa")## Complete model (with interaction):
##
## Df Sum Sq Mean Sq F value Pr(>F)
## Masa 2 3971 1985.7 0.775 0.563
## InstrumentoMedida 1 1458 1458.0 0.569 0.529
## Masa:InstrumentoMedida 2 5124 2562.2 3.617 0.059
## Repeatability 12 8499 708.3
## Total 17 19053
##
## alpha for removing interaction: 0.05
##
##
## Reduced model (without interaction):
##
## Df Sum Sq Mean Sq F value Pr(>F)
## Masa 2 3971 1985.7 2.041 0.167
## InstrumentoMedida 1 1458 1458.0 1.498 0.241
## Repeatability 14 13624 973.1
## Total 17 19053
##
## Gage R&R
##
## VarComp %Contrib
## Total Gage R&R 1026.99471 85.89
## Repeatability 973.11905 81.38
## Reproducibility 53.87566 4.51
## InstrumentoMedida 53.87566 4.51
## Part-To-Part 168.76720 14.11
## Total Variation 1195.76190 100.00
##
## StdDev StudyVar %StudyVar
## Total Gage R&R 32.046758 192.28055 92.67
## Repeatability 31.194856 187.16914 90.21
## Reproducibility 7.340004 44.04003 21.23
## InstrumentoMedida 7.340004 44.04003 21.23
## Part-To-Part 12.991043 77.94626 37.57
## Total Variation 34.579790 207.47874 100.00
##
## Number of Distinct Categories = 1## Warning in widths.x[pos.widths[[nm]]] <- widths.settings[[nm]] *
## widths.defaults[[nm]]$x: number of items to replace is not a multiple of
## replacement length
Estadistica con R
summary(sleep)## extra group ID
## Min. :-1.600 1:10 1 :2
## 1st Qu.:-0.025 2:10 2 :2
## Median : 0.950 3 :2
## Mean : 1.540 4 :2
## 3rd Qu.: 3.400 5 :2
## Max. : 5.500 6 :2
## (Other):8sleepboxplot(sleep$extra ~ sleep$group, col="lightblue", main = "Diferencias por grupo")
Regresion Lineal
plot(cars$speed, cars$dist)
lm.dist.speed <- lm(cars$dist ~ cars$speed)
lm.dist.speed##
## Call:
## lm(formula = cars$dist ~ cars$speed)
##
## Coefficients:
## (Intercept) cars$speed
## -17.579 3.932plot(cars$speed, cars$dist, col="gray")
abline(lm.dist.speed, col="red")
summary(lm.dist.speed)##
## Call:
## lm(formula = cars$dist ~ cars$speed)
##
## Residuals:
## Min 1Q Median 3Q Max
## -29.069 -9.525 -2.272 9.215 43.201
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -17.5791 6.7584 -2.601 0.0123 *
## cars$speed 3.9324 0.4155 9.464 1.49e-12 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 15.38 on 48 degrees of freedom
## Multiple R-squared: 0.6511, Adjusted R-squared: 0.6438
## F-statistic: 89.57 on 1 and 48 DF, p-value: 1.49e-12plot(lm.dist.speed, 1)
Regresion Logistica
datos <- as.data.frame(UCBAdmissions)
datos$Admit <- datos$Admit == "Admitted"
datosmodelo.sin.dept <- glm(Admit ~ Gender,
data = datos, weights = Freq,
family = binomial())
summary(modelo.sin.dept)##
## Call:
## glm(formula = Admit ~ Gender, family = binomial(), data = datos,
## weights = Freq)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -20.336 -15.244 1.781 14.662 28.787
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -0.22013 0.03879 -5.675 1.38e-08 ***
## GenderFemale -0.61035 0.06389 -9.553 < 2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 6044.3 on 23 degrees of freedom
## Residual deviance: 5950.9 on 22 degrees of freedom
## AIC: 5954.9
##
## Number of Fisher Scoring iterations: 4modelo.con.dept <- glm(Admit ~ Gender + Dept,
data = datos, weights = Freq,
family = binomial())
summary(modelo.con.dept)##
## Call:
## glm(formula = Admit ~ Gender + Dept, family = binomial(), data = datos,
## weights = Freq)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -25.3424 -13.0584 -0.1631 16.0167 21.3199
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 0.58205 0.06899 8.436 <2e-16 ***
## GenderFemale 0.09987 0.08085 1.235 0.217
## DeptB -0.04340 0.10984 -0.395 0.693
## DeptC -1.26260 0.10663 -11.841 <2e-16 ***
## DeptD -1.29461 0.10582 -12.234 <2e-16 ***
## DeptE -1.73931 0.12611 -13.792 <2e-16 ***
## DeptF -3.30648 0.16998 -19.452 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 6044.3 on 23 degrees of freedom
## Residual deviance: 5187.5 on 17 degrees of freedom
## AIC: 5201.5
##
## Number of Fisher Scoring iterations: 6ANOVA
modelo.aov <- aov(Admit ~ Gender + Dept,
data = datos, weights = Freq,
family = binomial())## Warning: In lm.wfit(x, y, w, offset = offset, singular.ok = singular.ok,
## ...) :
## extra argument 'family' will be disregardedsummary(modelo.aov)## Df Sum Sq Mean Sq F value Pr(>F)
## Gender 1 21.9 21.89 0.418 0.526
## Dept 5 163.3 32.66 0.624 0.683
## Residuals 17 889.3 52.31print(datos$Gender)## [1] Male Male Female Female Male Male Female Female Male Male
## [11] Female Female Male Male Female Female Male Male Female Female
## [21] Male Male Female Female
## Levels: Male FemaleUCBAdmissions## , , Dept = A
##
## Gender
## Admit Male Female
## Admitted 512 89
## Rejected 313 19
##
## , , Dept = B
##
## Gender
## Admit Male Female
## Admitted 353 17
## Rejected 207 8
##
## , , Dept = C
##
## Gender
## Admit Male Female
## Admitted 120 202
## Rejected 205 391
##
## , , Dept = D
##
## Gender
## Admit Male Female
## Admitted 138 131
## Rejected 279 244
##
## , , Dept = E
##
## Gender
## Admit Male Female
## Admitted 53 94
## Rejected 138 299
##
## , , Dept = F
##
## Gender
## Admit Male Female
## Admitted 22 24
## Rejected 351 317Representaciones 3D
library(MSQC)
library("MSQC", lib.loc="~/R/win-library/3.1")
data(package="MSQC")
library(qcc)
citation("qcc")To cite qcc in publications use:
Scrucca, L. (2004). qcc: an R package for quality control charting and statistical process control. R News 4/1, 11-17.
A BibTeX entry for LaTeX users is
@Article{, title = {qcc: an R package for quality control charting and statistical process control}, author = {Luca Scrucca}, journal = {R News}, year = {2004}, pages = {11–17}, volume = {4/1}, url = {https://cran.r-project.org/doc/Rnews/}, }
#Scrucca, L. (2004). qcc: an R package for quality control
#charting and statistical process control. R News 4/1, 11-17.
set.seed(20)
x <-round(rnorm(120,20,2),2)
length <-matrix(x, ncol=4, byrow=TRUE)
par(mfrow=c(1,2))
qcc(length, type="xbar", std.dev="RMSDF"); qcc(length, type="R")
List
of 11 $ call : language qcc(data = length, type = “xbar”, std.dev =
“RMSDF”) $ type : chr “xbar” $ data.name : chr “length” $ data : num
[1:30, 1:4] 22.3 19.1 19.1 18.7 21.9 … ..- attr(, “dimnames”)=List
of 2 $ statistics: Named num [1:30] 20.5 18.2 19.4 19.4 20.7 … ..-
attr(, “names”)= chr [1:30] “1” “2” “3” “4” … $ sizes : int [1:30]
4 4 4 4 4 4 4 4 4 4 … $ center : num 20 $ std.dev : num 2.03 $ nsigmas :
num 3 $ limits : num [1, 1:2] 17 23.1 ..- attr(, “dimnames”)=List of
2 $ violations:List of 2 - attr(, “class”)= chr “qcc”
List
of 11 $ call : language qcc(data = length, type = “R”) $ type : chr “R”
$ data.name : chr “length” $ data : num [1:30, 1:4] 22.3 19.1 19.1 18.7
21.9 … ..- attr(, “dimnames”)=List of 2 $ statistics: Named num
[1:30] 6.24 6.92 1.07 5.69 2.11 … ..- attr(, “names”)= chr [1:30]
“1” “2” “3” “4” … $ sizes : int [1:30] 4 4 4 4 4 4 4 4 4 4 … $ center :
num 4.07 $ std.dev : num 1.98 $ nsigmas : num 3 $ limits : num [1, 1:2]
0 9.28 ..- attr(, “dimnames”)=List of 2 $ violations:List of 2 -
attr(, “class”)= chr “qcc”
cap<-qcc(length, type="xbar", nsigmas=3, plot=T)
process.capability(cap, spec.limits=c(14,26))
##
## Process Capability Analysis
##
## Call:
## process.capability(object = cap, spec.limits = c(14, 26))
##
## Number of obs = 120 Target = 20
## Center = 20.01 LSL = 14
## StdDev = 1.976 USL = 26
##
## Capability indices:
##
## Value 2.5% 97.5%
## Cp 1.012 0.8837 1.141
## Cp_l 1.014 0.8952 1.134
## Cp_u 1.010 0.8913 1.129
## Cp_k 1.010 0.8685 1.152
## Cpm 1.012 0.8842 1.140
##
## Exp<LSL 0.12% Obs<LSL 0%
## Exp>USL 0.12% Obs>USL 0%#
mu <-c(0,0) # The Mean vector - "mu" of a Bivariate Normal Distribution
sigma <- matrix(c(10,3,3,6),2,2) # Sigma the Covariance Matrix
# The Square Covariance Matrix structure needs to be seen and understood ...
sigma## [,1] [,2]
## [1,] 10 3
## [2,] 3 6sigma[1,1]## [1] 10# Which is the Observation "10" t location - Row - 1 and Column -1, within the Square Matrix "sigma"
sigma[2,2]## [1] 6# Which is the Observation "6" at location - Row - 2 and Column -2 , within the Square Matrix "sigma"rho <- sigma[1,2]/(sqrt(sigma[1,1]*sigma[2,2]))
rho## [1] 0.3872983# rho=3/(sqrt(10*6))
# dummy<-3/sqrt(60) - same as value of "rho"
var1<-seq(-12,12,.7)
var1## [1] -12.0 -11.3 -10.6 -9.9 -9.2 -8.5 -7.8 -7.1 -6.4 -5.7 -5.0 -4.3
## [13] -3.6 -2.9 -2.2 -1.5 -0.8 -0.1 0.6 1.3 2.0 2.7 3.4 4.1
## [25] 4.8 5.5 6.2 6.9 7.6 8.3 9.0 9.7 10.4 11.1 11.8var2<-var1
knitr::kable(var2)| x |
|---|
| -12.0 |
| -11.3 |
| -10.6 |
| -9.9 |
| -9.2 |
| -8.5 |
| -7.8 |
| -7.1 |
| -6.4 |
| -5.7 |
| -5.0 |
| -4.3 |
| -3.6 |
| -2.9 |
| -2.2 |
| -1.5 |
| -0.8 |
| -0.1 |
| 0.6 |
| 1.3 |
| 2.0 |
| 2.7 |
| 3.4 |
| 4.1 |
| 4.8 |
| 5.5 |
| 6.2 |
| 6.9 |
| 7.6 |
| 8.3 |
| 9.0 |
| 9.7 |
| 10.4 |
| 11.1 |
| 11.8 |
f<-matrix(0, length(var1), length(var1))
for(i in 1:length(var1))
{
for(j in 1:length(var1))
{
f[i,j]<-1/(2*pi*sqrt(sigma[1,1]*sigma[2,2]*(1-rho^2)))*exp(-1/(2*(1-rho^2)) * ((var1[i]-mu[1])^2/sigma[1,1] + (var2[j] - mu[2])^2/sigma[2,2]-2 *rho*((var1[i] - mu[1])*(var2[j]-mu[2]))/(sqrt(sigma[1,1])*sqrt(sigma[2,2]))))}}
str(f)## num [1:35, 1:35] 1.65e-08 2.62e-08 3.94e-08 5.60e-08 7.50e-08 ...persp(var1,var2,f,xlab="Var-1",ylab="Var-2",zlab="f(var1,var2)",
theta=30,phi=30,col = "red",shade = 0.05,r=50,d=0.02,expand=0.9,ltheta=90,lphi=180, nticks=4,box=F)
jet.colors <- colorRampPalette( c("blue", "green") )
#
nbcol <- 100
color <- jet.colors(nbcol)
persp(var1,var2,f,xlab="Var-1",ylab="Var-2",zlab="f(var1,var2)",
theta=30,phi=30,col = color,shade = 0.05,r=50,d=0.02,expand=0.9,ltheta=90,lphi=180, nticks=4,box=T)
# Further Shading - using Code from help -persp {graphics}
z <- outer(var1, var2, function(a, b) a*b^2)
nrz <- nrow(z)
ncz <- ncol(z)
# Compute the z-value at the facet centres
zfacet <- z[-1, -1] + z[-1, -ncz] + z[-nrz, -1] + z[-nrz, -ncz]
# Recode facet z-values into color indices
facetcol <- cut(zfacet, nbcol)
persp(var1,var2,f,xlab="Var-1",ylab="Var-2",zlab="f(var1,var2)",
theta=30,phi=30,col = color[facetcol],shade = 0.05,r=50,d=0.02,expand=0.9,ltheta=90,lphi=180, nticks=4,box=F)
# In the Above seen Perspective Plot - persp {graphics}
# f == the matrix containing values to be plotted.persp(var1,var2,f,xlab="Var-1",ylab="Var-2",zlab="f(var1,var2)",
theta=30,phi=30,col = "red",shade = 0.05,r=50,d=0.02,expand=0.9,ltheta=90,lphi=180, nticks=4,box=F)
jet.colors <- colorRampPalette( c("pink", "red") )
#
nbcol <- 100
color <- jet.colors(nbcol)
persp(var1,var2,f,xlab="Var-1",ylab="Var-2",zlab="f(var1,var2)",
theta=30,phi=30,col = color,shade = 0.05,r=50,d=0.02,expand=0.9,ltheta=90,lphi=180, nticks=4,box=T)
# Further Shading - using Code from help -persp {graphics}
z <- outer(var1, var2, function(a, b) a*b^2)
nrz <- nrow(z)
ncz <- ncol(z)
# Compute the z-value at the facet centres
zfacet <- z[-1, -1] + z[-1, -ncz] + z[-nrz, -1] + z[-nrz, -ncz]
# Recode facet z-values into color indices
facetcol <- cut(zfacet, nbcol)
persp(var1,var2,f,xlab="Var-1",ylab="Var-2",zlab="f(var1,var2)",
theta=30,phi=30,col = color[facetcol],shade = 0.05,r=50,d=0.02,expand=0.9,ltheta=90,lphi=180, nticks=4,box=T)
In the Above seen Perspective Plot - persp {graphics}
f == the matrix containing values to be plotted.
R Six Sigma 3D Scatter Plots / Graphs - using data set “dowel1” and dowel2”
from package / library(MSQC)
data(dowel1) View(dowel1) # ?dowel1
library(scatterplot3d)
library("scatterplot3d", lib.loc="~/R/win-library/3.1")Sample 3D Scatter Plot
scatterplot3d(x=mtcars$wt,
y=mtcars$disp,
z=mtcars$mpg,angle=10,color=rgb(.5, .5, .5, .5),pch=20,grid=T,highlight.3d=TRUE, col.axis="blue",
col.grid="lightblue") # as we have used - highlight.3d=TRUE , the - color=rgb(.5, .5, .5, .5) , is ignored but still retained in the code. ## Warning in scatterplot3d(x = mtcars$wt, y = mtcars$disp, z = mtcars$mpg, : color
## is ignored when highlight.3d = TRUE
scatterplot3d(x=mtcars$wt,
y=mtcars$disp,
z=mtcars$mpg,angle=30,color=rgb(.5, .5, .5, .5),pch=20,grid=T,highlight.3d=TRUE, col.axis="blue",
col.grid="lightblue")## Warning in scatterplot3d(x = mtcars$wt, y = mtcars$disp, z = mtcars$mpg, : color
## is ignored when highlight.3d = TRUE
## Warning in scatterplot3d(x = mtcars$wt, y = mtcars$disp, z = mtcars$mpg, :
## color is ignored when highlight.3d = TRUE#
scatterplot3d(x=mtcars$wt,
y=mtcars$disp,
z=mtcars$mpg,angle=50,color=rgb(.5, .5, .5, .5),pch=20,grid=T,highlight.3d=TRUE, col.axis="blue",
col.grid="lightblue")## Warning in scatterplot3d(x = mtcars$wt, y = mtcars$disp, z = mtcars$mpg, : color
## is ignored when highlight.3d = TRUE
## Warning in scatterplot3d(x = mtcars$wt, y = mtcars$disp, z = mtcars$mpg, :
## color is ignored when highlight.3d = TRUE# Code below this point is for Testin need not be Run
# Experiment -1
zz <- seq(-10, 10,length.out=1000)
# zz
xx<-cos(zz)
yy<-sin(zz)
scatterplot3d(xx, yy, zz, highlight.3d=TRUE, col.axis="blue",
col.grid="lightblue", main="Scatter-plot3d-1 [ Data Length =1000 Obs.] ", cex.symbols=2,pch=20)
# Experiment -2
zz2 <- seq(-10, 10,length.out=1000)
# zz
xx2<-1-(zz2)
yy2<-10-(zz2)
scatterplot3d(xx2, yy2, zz2, highlight.3d=TRUE, col.axis="blue",
col.grid="lightblue", main="Scatter-plot3d-1 [ Data Length =1000 Obs.] ", cex.symbols=2,pch=20)
# Bibliografia
Rohit GitHub Statistical Quality Control (SQC) using “R” Edgar Santos-Fernández, Michele Scagliarini https://rpubs.com/rohitdhankaranalytics/SQC_USE_R
Santos-Fernández, E. (2012). Multivariate Statistical Quality Control Using R. SpringerBriefs in Statistics. doi:10.1007/978-1-4614-5453-3 https://sci-hub.se/10.1007/978-1-4614-5453-3
Correlation, Variance and Covariance (Matrices) Becker, R. A., Chambers, J. M. and Wilks, A. R. (1988). The New S Language. Wadsworth & Brooks/Cole.
Kendall, M. G. (1938). A new measure of rank correlation, Biometrika, 30, 81–93. doi:10.1093/biomet/30.1-2.81.
Kendall, M. G. (1945). The treatment of ties in rank problems. Biometrika, 33 239–251. doi:10.1093/biomet/33.3.239 https://stat.ethz.ch/R-manual/R-devel/library/stats/html/cor.html
Control Charts with qicharts for R Jacob Anhoej https://cran.r-project.org/web/packages/qicharts/vignettes/controlcharts.html
Gráficos de control no paramétricos basados en R-estadísticos con aplicación al caso multivariante https://core.ac.uk/download/pdf/29405069.pdf