Curva de operación (CO) - Distribución binomial
N. Cortés D. \ informacion@farmaciayestadistica.com
Para acceder a una explicación detallada sobre la aplicación de este código, visite el siguiente enlace.
Tabla de frecuencias de la distribución binomial para X~Binom(n=100,p=0.03)
n=100 #
p=0.03
nlim=10
mat<- matrix(0,nlim+1,3)
for (i in 0:nlim) {
mat[i+1,1] <- i
mat[i+1,2] <- round(dbinom(i, size = n, prob = p),4)
mat[i+1,3] <- sum(mat[1:(i+1), 2])
mat_df <- as.data.frame(mat)
colnames(mat_df) <- c("Proporción de defectuosos",
"Probabilidad absoluta",
"Probabilidad acumulada")
}
mat_df## Proporción de defectuosos Probabilidad absoluta Probabilidad acumulada
## 1 0 0.0476 0.0476
## 2 1 0.1471 0.1947
## 3 2 0.2252 0.4199
## 4 3 0.2275 0.6474
## 5 4 0.1706 0.8180
## 6 5 0.1013 0.9193
## 7 6 0.0496 0.9689
## 8 7 0.0206 0.9895
## 9 8 0.0074 0.9969
## 10 9 0.0023 0.9992
## 11 10 0.0007 0.9999Graficos de función de masa y gráfico de distribución acumulada para X~Binom(n=100,p=0.03)
# Distribución binomial - Gráfico de función de masa
n=100
p=0.03
nlim=10
par(mfrow=c(1, 2), mai = c(0.5, 0.5, 0.5, 0.2))
rango <- c(0,nlim)
x <- seq(from=rango[1],to=rango[2],by=1)
pbinom <- dbinom(x, size = n, prob = p)
color="#836FFF"
plot(x,pbinom,bty="o",type="h",lwd=1,lty="solid",
col=color,xlab="x",ylab=bquote(~f[X](x)), cex=1.5,
ylim = c(0, max(pbinom)+0.02),cex.axis = 1.5, cex.lab = 1.5)
points(x,pbinom,pch=20,cex=1,col=color)
title(bquote(X ~ "~ Binomial(" * n == .(n) * ", p =" * .(p) * ")"), cex.main = 2)
labels <- ifelse(pbinom > 0.002,round(pbinom,digits=2),"")
text(x,pbinom,label=labels,pos=4,cex=1.5,col="black")
# Distribución binomial - Grafico de función de distribución acumulada
x <- seq(from=rango[1]-1,to=rango[2],by=1)
pbinom <- pbinom(x,size=n,prob=p)
plot(x, pbinom, pch = 16, col = color, lwd = 1,
xlab = "x", ylab = bquote(~F[X](x)), cex = 1.5,
ylim = c(0, 1.1), cex.axis = 1.5, cex.lab = 1.5)
segments(x,pbinom,x+1,pbinom,col=color,lty=1,lwd=1)
title(bquote(X ~ "~ Binomial(" * n == .(n) * ", p =" * .(p) * ")"), cex.main = 2)
labels <- ifelse(pbinom < 0.99 & pbinom > 0.001,round(pbinom,digits=2),"")
text(x,pbinom,label=labels,pos=3,cex=1.5,col="black")
Funcion para los gráficos distribución binomial (dbinomg)
Esta función muestra los gráficos de la función de distribución de masa y la función de distribución acumulada para la distribución binomial.
- Parámetros:
n: Número de ensayos independientes.p: Probabilidad de éxito.nlim: Número máximo hasta el cual se calcularán las probabilidades.
dbinomg <- function(n,p,nlim){
# Distribución binomial
rango <- c(0,nlim)
x <- seq(0,nlim,by=1)
pbinom <- dbinom(x, size = n, prob = p)
color="#836FFF"
plot(x,pbinom,bty="o",type="h",lwd=1,lty="solid",
col=color,xlab="x",ylab=bquote(~f[X](x)),
cex=0.7,ylim = c(0, 1.02),xaxt = "n")
points(x,pbinom,pch=20,cex=0.5,col=color)
title(bquote(X ~ "~ Binomial(" * n == .(n) * ", p =" * .(p) * ")"), cex.main = 1)
labels <- ifelse(pbinom > 0.001,round(pbinom,digits=3),"")
text(x,pbinom,label=labels,pos=3,cex=1.0,col="black")
x_labels <- seq(0, nlim, by = 1)
axis(1, at = x_labels, labels = as.character(x_labels))
}Gráficas de función de masa para X~Binom(n=100,p=0.03) con varias probabilidades con un mismo n
p=c(0.010, 0.020, 0.030, 0.040, 0.050, 0.060)
n=100
nlim=10
par(mfrow=c(3, 2))
par(mar = c(2, 2, 2, 2))
for (prob in p) {
dbinomg(n, prob, nlim)
}
Tabla de frecuencias de la distribución binomial para X~Binom(n=100,p=0.03)
A continuación, se presentan las probabilidades acumuladas calculadas para las siguientes proporciones de unidades defectuosas: 0.001, 0.005, 0.01, 0.015, 0.02, 0.03, 0.04, 0.05, 0.06, 0.07, 0.08 y 0.1:
## Num_defect 0.001 0.005 0.01 0.015 0.02 0.03 0.04 0.05 0.06 0.07 0.08 0.1
## 1 0 0.9 0.61 0.37 0.22 0.13 0.05 0.02 0.01 0.00 0.00 0.00 0.00
## 2 1 1.0 0.91 0.74 0.56 0.40 0.19 0.09 0.04 0.02 0.01 0.00 0.00
## 3 2 1.0 0.99 0.92 0.81 0.68 0.42 0.23 0.12 0.06 0.03 0.01 0.00
## 4 3 1.0 1.00 0.98 0.94 0.86 0.65 0.43 0.26 0.14 0.07 0.04 0.01
## 5 4 1.0 1.00 1.00 0.98 0.95 0.82 0.63 0.44 0.28 0.16 0.09 0.02
## 6 5 1.0 1.00 1.00 1.00 0.98 0.92 0.79 0.62 0.44 0.29 0.18 0.06
## 7 6 1.0 1.00 1.00 1.00 1.00 0.97 0.89 0.77 0.61 0.44 0.30 0.12
## 8 7 1.0 1.00 1.00 1.00 1.00 0.99 0.95 0.87 0.75 0.60 0.45 0.21
## 9 8 1.0 1.00 1.00 1.00 1.00 1.00 0.98 0.94 0.85 0.73 0.59 0.32
## 10 9 1.0 1.00 1.00 1.00 1.00 1.00 0.99 0.97 0.92 0.84 0.72 0.45
## 11 10 1.0 1.00 1.00 1.00 1.00 1.00 1.00 0.99 0.96 0.91 0.82 0.58
Tabla de probabilidad de aceptación con c definido para diferentes proporciones de unidades defectuosas utilizando la función dbinom
c=1
n=100
p <- c(0.001, 0.005, 0.010, 0.015, 0.020, 0.030, 0.040, 0.050, 0.060, 0.070, 0.080, 0.100)
mat <- matrix(0, nrow = length(p), ncol = 2)
for (i in 1:length(p)) {
mat[i, 1] <- p[i]
mat[i, 2] <- round(sum(dbinom(0:c, size = n, prob = p[i])),3)
mat_df <- as.data.frame(mat)
colnames(mat_df) <- c("Proporción de defectuosos", "Probabilidad de aceptación")
}
mat_df## Proporción de defectuosos Probabilidad de aceptación
## 1 0.001 0.995
## 2 0.005 0.910
## 3 0.010 0.736
## 4 0.015 0.557
## 5 0.020 0.403
## 6 0.030 0.195
## 7 0.040 0.087
## 8 0.050 0.037
## 9 0.060 0.015
## 10 0.070 0.006
## 11 0.080 0.002
## 12 0.100 0.000Tabla de probabilidad de aceptación con c definido para diferentes proporciones de unidades defectuosas utilizando la función pbinom
c=1
n=100
p <- c(0.001, 0.005, 0.010, 0.015, 0.020, 0.030, 0.040, 0.050, 0.060, 0.070, 0.080, 0.100)
mat <- matrix(0, nrow = length(p), ncol = 2)
for (i in 1:length(p)) {
mat[i, 1] <- p[i]
mat[i, 2] <- round(pbinom(c, size = n, prob = p[i]),3)
mat_df <- as.data.frame(mat)
colnames(mat_df) <- c("Proporción de defectuosos", "Probabilidad de aceptación")
}
mat_df## Proporción de defectuosos Probabilidad de aceptación
## 1 0.001 0.995
## 2 0.005 0.910
## 3 0.010 0.736
## 4 0.015 0.557
## 5 0.020 0.403
## 6 0.030 0.195
## 7 0.040 0.087
## 8 0.050 0.037
## 9 0.060 0.015
## 10 0.070 0.006
## 11 0.080 0.002
## 12 0.100 0.000Función para graficar la curva CO (COcurbin)
Esta función muestra los gráficos de la función de distribución de masa y la función de distribución acumulada para la distribución binomial.
- Parámetros:
n: Número de ensayos independientes.p: Probabilidad de éxito.nlim: Número máximo hasta el cual se calcularán las probabilidades.
COcurbin <- function(c,n, nac){
p <- c(0.001, 0.005, 0.010, 0.015, 0.020, 0.030, 0.040, 0.050, 0.060, 0.070, 0.080, 0.100)
prob_acumulada <- pbinom(c, size = n, prob = p)
tab <- data.frame(p, round(prob_acumulada,3))
colnames(tab) <- c("Proporción de defectuosos",
(paste("n=",n,",","c=",c)))
print(tab)
plot(p, prob_acumulada, type = "l", col = "#836FFF", lwd = 2,
xlab = expression(paste("Proporción de artículos defectuosos en el lote ", italic("p"))),
ylab = expression(paste("Probabilidad de aceptar ", italic("Pa"))),
main = bquote(paste("Curva CO para el plan (", n == .(n),", ", c == .(c), ")")))
points(p, prob_acumulada, pch = 16, col = "#836FFF")
labels <- ifelse(pbinom > 0.002,round(prob_acumulada,digits=2),"")
text(p,prob_acumulada,label=labels,pos=3,cex=0.7,col="black", offset = 1)
segments(nac, 0, nac, pbinom(c, size = n, prob = nac), col = "red", lty = 2, lwd = 1)
abline(v=nac, lty = 2, col = "red")
}COcurbin(1,100,0.005)## Proporción de defectuosos n= 100 , c= 1
## 1 0.001 0.995
## 2 0.005 0.910
## 3 0.010 0.736
## 4 0.015 0.557
## 5 0.020 0.403
## 6 0.030 0.195
## 7 0.040 0.087
## 8 0.050 0.037
## 9 0.060 0.015
## 10 0.070 0.006
## 11 0.080 0.002
## 12 0.100 0.000
Función para graficar varias curvas CO (COcurbinv)
Esta función muestra las curvas de operación (CO) de acuerdo con los siguientes parámetros:
- Parámetros:
c1,c2,c3: Números de unidades defectuosas permitidas para aceptar en la muestra.n1,n2,n3: Tamaños de muestra.nac: Nivel aceptable de calidad.
COcurbinv <- function(c1,n1,c2,n2,c3,n3,nac){
p <- c(0.001, 0.005, 0.010, 0.015, 0.020, 0.030, 0.040, 0.050, 0.060, 0.070, 0.080, 0.100)
prob_acumulada1 <- pbinom(c1, size = n1, prob = p)
prob_acumulada2 <- pbinom(c2, size = n2, prob = p)
prob_acumulada3 <- pbinom(c3, size = n3, prob = p)
tab <- data.frame(p, round(prob_acumulada1,3), round(prob_acumulada2,3), round(prob_acumulada3,3))
colnames(tab) <- c("Proporción de defectuosos",
(paste("n=",n1,",","c=",c1)),
(paste("n=",n2,",","c=",c2)),
(paste("n=",n3,",","c=",c3)))
print(tab)
plot(p, prob_acumulada1, type = "l", col = "#836FFF", lwd = 2,
xlab = expression(paste("Proporción de artículos defectuosos en el lote ", italic("p"))),
ylab = expression(paste("Probabilidad de aceptación ", italic("Pa"))),
main = "Comparación de curvas CO",
ylim = c(0, max(c(prob_acumulada1, prob_acumulada2,prob_acumulada3))+0.02))
lines(p, prob_acumulada2, col = "#00FF7F", lwd = 2, lty=1)
lines(p, prob_acumulada3, col = "#00F5FF", lwd = 2, lty=1)
points(p, prob_acumulada1, pch = 16, col = "#836FFF")
points(p, prob_acumulada2, pch = 16, col = "#00FF7F")
points(p, prob_acumulada3, pch = 16, col = "#00F5FF")
abline(v=nac, lty = 2, col = "red")
legend("topright", legend = c((bquote(paste(n == .(n1),", ", c == .(c1)))),
(bquote(paste(n == .(n2),", ", c == .(c2)))),
(bquote(paste(n == .(n3),", ", c == .(c3)))),
(paste("NAC=", nac))),
col = c("slateblue2", "#00FF7F", "#00F5FF", "red"), lwd = 2, lty=1,
title = "Planes", cex = 0.8)
}Comparación de curvas CO: Incremento proporcional del tamaño de la muestra (n) y de número de unidades defectuosas dispuestos a aceptar (c)
COcurbinv(c1=1,n1=100,c2=2,n2=200,c3=4,n3=400,nac=0.005)## Proporción de defectuosos n= 100 , c= 1 n= 200 , c= 2 n= 400 , c= 4
## 1 0.001 0.995 0.999 1.000
## 2 0.005 0.910 0.920 0.948
## 3 0.010 0.736 0.677 0.629
## 4 0.015 0.557 0.421 0.283
## 5 0.020 0.403 0.235 0.097
## 6 0.030 0.195 0.059 0.007
## 7 0.040 0.087 0.012 0.000
## 8 0.050 0.037 0.002 0.000
## 9 0.060 0.015 0.000 0.000
## 10 0.070 0.006 0.000 0.000
## 11 0.080 0.002 0.000 0.000
## 12 0.100 0.000 0.000 0.000
Comparación de curvas CO: Modificación del número de unidades defectuosas dispuestos a aceptar (c) con tamaño de muestra constante (n)
COcurbinv(0,100,1,100,3,100,0.005)## Proporción de defectuosos n= 100 , c= 0 n= 100 , c= 1 n= 100 , c= 3
## 1 0.001 0.905 0.995 1.000
## 2 0.005 0.606 0.910 0.998
## 3 0.010 0.366 0.736 0.982
## 4 0.015 0.221 0.557 0.936
## 5 0.020 0.133 0.403 0.859
## 6 0.030 0.048 0.195 0.647
## 7 0.040 0.017 0.087 0.429
## 8 0.050 0.006 0.037 0.258
## 9 0.060 0.002 0.015 0.143
## 10 0.070 0.001 0.006 0.074
## 11 0.080 0.000 0.002 0.037
## 12 0.100 0.000 0.000 0.008
Comparación de curvas CO: Número de unidades defectuosas dispuestos a aceptar (c) como porcentaje del tamaño del lote
COcurbinv(0,30,0,50,0,80,0.005)## Proporción de defectuosos n= 30 , c= 0 n= 50 , c= 0 n= 80 , c= 0
## 1 0.001 0.970 0.951 0.923
## 2 0.005 0.860 0.778 0.670
## 3 0.010 0.740 0.605 0.448
## 4 0.015 0.635 0.470 0.298
## 5 0.020 0.545 0.364 0.199
## 6 0.030 0.401 0.218 0.087
## 7 0.040 0.294 0.130 0.038
## 8 0.050 0.215 0.077 0.017
## 9 0.060 0.156 0.045 0.007
## 10 0.070 0.113 0.027 0.003
## 11 0.080 0.082 0.015 0.001
## 12 0.100 0.042 0.005 0.000
COcurbinv(3,30,5,50,8,80,0.005)## Proporción de defectuosos n= 30 , c= 3 n= 50 , c= 5 n= 80 , c= 8
## 1 0.001 1.000 1.000 1.000
## 2 0.005 1.000 1.000 1.000
## 3 0.010 1.000 1.000 1.000
## 4 0.015 0.999 1.000 1.000
## 5 0.020 0.997 1.000 1.000
## 6 0.030 0.988 0.996 0.999
## 7 0.040 0.969 0.986 0.995
## 8 0.050 0.939 0.962 0.982
## 9 0.060 0.897 0.922 0.950
## 10 0.070 0.845 0.865 0.893
## 11 0.080 0.784 0.792 0.811
## 12 0.100 0.647 0.616 0.593
Referencias:
https://www.farmaciayestadistica.com/tutoriales/detalle/89/curvas-de-operacion-co?id=sm-89.
Cristina Sierra, I., & Trujillo González, M. (2014). Propuesta de una guía de análisis para el control de calidad de envases metálicos de aerosol de 25, 4 mm de diámetro de boca.Revista Colombiana de Ciencias Químico-Farmacéuticas,43(2), 248-264. Para acceder al artículo, visite el siguiente enlace.
Gutiérrez Pulido, H., & De la Vara Salazar, R. (2009). Control estadístico de calidad y seis sigma. México DF: Mc Graw Hill.
- Schilling, E. G., & Neubauer, D. V. (2009). Acceptance sampling in quality control. Chapman and Hall/CRC.
