Experimento
El experimento consistía en que cada alumno realizara 15 tiros utilizando la catapulta virtual, donde se podían modificar varios puntos antes de realizar el disparo. Se eligieron 3 configuraciones para ajustarla y cada alumno tenía que realizar 5 tiros por cada configuración, un total de 15 tiros, y medir la distancia del tiro. Las configuraciones elegidas fueron las siguientes:
Dataset
datos=read.csv2('registro.csv',sep=',')
library(dplyr)
library(tidyverse)
nombre=as.character(datos$OPERARIO)
nombre=str_split(nombre,'@')
nombres=lapply(nombre, `[[`, 1)
nombres=as.factor(unlist(nombres))
Operarios=paste0("OP", rep(1:length(levels(datos$OPERARIO)),each=15))
datos$nombres=(paste(nombres,sep = ' ',Operarios))
Catapulta= datos%>% select(c('OPERARIO','DISTANCIA','TIRO','ELEMENTO','nombres'))
Catapulta$ELEMENTO=as.factor(Catapulta$ELEMENTO)
Catapulta$OPERARIO=as.factor(Catapulta$OPERARIO)
library(kableExtra)
TABLA=table(Catapulta$nombres,Catapulta$ELEMENTO)
kable(TABLA) %>%
kable_styling() %>%
row_spec(3, bold = T, color = "white", background = "#D04F4D")| 185113300169185 | 185120300200200 | 185135270200200 | |
|---|---|---|---|
| alberto.sancho OP1 | 5 | 5 | 5 |
| alejandro.gimenez02 OP2 | 5 | 5 | 5 |
| alexandro.garcia OP3 | 6 | 5 | 4 |
| alicia.diaz02 OP4 | 5 | 5 | 5 |
| andrea.valiente OP5 | 5 | 5 | 5 |
| christian.ledesma OP6 | 5 | 5 | 5 |
| cristina.sotos OP7 | 5 | 5 | 5 |
| diego.garcia09 OP8 | 5 | 5 | 5 |
| dimitar.malamov OP9 | 5 | 5 | 5 |
| esther.sobrino OP10 | 5 | 5 | 5 |
| francisco.richarte OP11 | 5 | 5 | 5 |
| gurwinder.singh OP12 | 5 | 5 | 5 |
| javier.caro01 OP13 | 5 | 5 | 5 |
| jose.garcia105 OP14 | 5 | 5 | 5 |
| juan.garcia103 OP15 | 5 | 5 | 5 |
| lorena.nacher OP16 | 5 | 5 | 5 |
| mireia.bou OP17 | 5 | 5 | 5 |
| miriam.castello OP18 | 5 | 5 | 5 |
| pablo.pages OP19 | 5 | 5 | 5 |
| pablo.perez14 OP20 | 5 | 5 | 5 |
| sandy.sailema OP21 | 5 | 5 | 5 |
| sukhwinder.singh OP22 | 5 | 5 | 5 |
| victor.pacheco01 OP23 | 5 | 5 | 5 |
Observamos en la tabla que hay un operario al que le falta algún tiro para algunas configuraciones lo cual va producir un sesgo en el análisis.
Análisis Gage R&R
Los principales objetivos del análisis gage en nuestro caso, es responder a las siguientes preguntas relativas a la fiabilidad del sistema de medición.
- ¿Es capaz el sistema de discriminar entre los distintos operarios y elementos?
- ¿Hay algún elemento que presente una mayor variabilidad entre sus mediciones, es decir, existe algún elemento no reproducible?
- ¿Hay problemas de repetitividad?
- En conclusión, ¿es fiable el sistema de medición?
Para poder comprender e interpretar los gráficos con una mayor facilidad, hemos renombrado los operarios como OP1,OP2… y las 3 configuraciones como E1 = CAC, E2 = GHOST y E3 = HUFFLEPUFF.
Catapulta1=Catapulta
Operarios=paste0("OP", rep(1:length(levels(Catapulta$OPERARIO))))
levels(Catapulta1$OPERARIO)=Operarios
levels(Catapulta1$ELEMENTO)=c('E1','E2','E3')
library(SixSigma)
# ss.rr(var, part, appr, data, main, sub)
my.rr <- ss.rr(var = DISTANCIA, part = ELEMENTO,
appr =OPERARIO ,
data = Catapulta1,
main = "Six Sigma Gage R&R Measure",
sub = "cATAPULTA")## Complete model (with interaction):
##
## Df Sum Sq Mean Sq F value Pr(>F)
## ELEMENTO 2 2457310 1228655 211.882 <2e-16
## OPERARIO 22 115212 5237 0.903 0.591
## ELEMENTO:OPERARIO 44 255146 5799 7.723 <2e-16
## Repeatability 276 207241 751
## Total 344 3034910
##
## alpha for removing interaction: 0.05
##
## Gage R&R
##
## VarComp %Contrib
## Total Gage R&R 1760.4541 14.20
## Repeatability 750.8729 6.06
## Reproducibility 1009.5812 8.15
## OPERARIO 0.0000 0.00
## ELEMENTO:OPERARIO 1009.5812 8.15
## Part-To-Part 10633.5344 85.80
## Total Variation 12393.9884 100.00
##
## StdDev StudyVar %StudyVar
## Total Gage R&R 41.95777 251.7466 37.69
## Repeatability 27.40206 164.4124 24.61
## Reproducibility 31.77391 190.6434 28.54
## OPERARIO 0.00000 0.0000 0.00
## ELEMENTO:OPERARIO 31.77391 190.6434 28.54
## Part-To-Part 103.11903 618.7142 92.63
## Total Variation 111.32829 667.9697 100.00
##
## Number of Distinct Categories = 3
Gráficos
var = 'DISTANCIA'
part = 'ELEMENTO'
#part=deparse(substitute(part))
data = Catapulta1
appr='OPERARIO'
#appr=deparse(substitute(appr))
if (part %in% names(data)) {
data[[part]] <- factor(data[[part]])}
if (appr %in% names(data)) {
data[[appr]] <- factor(data[[appr]])}
a <- nlevels(data[[part]])
b <- nlevels(data[[appr]])
n <- nrow(data)/(a*b)
plot1 <- lattice::stripplot(as.formula(paste(var, "~", part)),
data = data,
grid = TRUE,
par.settings = list(axis.text = list(cex = 0.6),
par.xlab.text = list(cex = 0.8),
par.ylab.text = list(cex = 0.8),
par.main.text = list(cex = 0.9)),
main = paste(var, "by", part),
type = c("p", "a"))
plot1
plot2 <- lattice::stripplot(as.formula(paste(var, "~", appr)),
data = data,
grid = TRUE,
par.settings = list(axis.text = list(cex = 0.6),
par.xlab.text = list(cex = 0.8),
par.ylab.text = list(cex = 0.8),
par.main.text = list(cex = 0.9)),
main = paste(var, "by", appr),
type = c("p", "a"))
plot2
data.xbar <- aggregate(as.formula(paste(var, "~", appr, "+", part)),
data = data, mean)
plot3 <- lattice::stripplot(as.formula(paste(var, "~", part)),
groups = get(appr),
data = data.xbar,
pch = 16,
grid = TRUE,
par.settings = list(par.main.text = list(cex = 1.2),
par.xlab.text = list(cex = 2.6),
par.ylab.text = list(cex = 1.4)),
main = paste0(part, ":", appr, " Interaction"),
type = c("p", "a"),
auto.key = list(text = levels(data[[appr]]),
columns = 10,
space = "top",
cex = 1.1, lines = TRUE,
points = FALSE, adj = 1))
plot3
rowstoplot <- c(1, 2, 3, 6)
colstoplot<-c(2,5)
klabels <- c("%Contribution", "%Study Var")
varianzas=cbind(my.rr$varComp,my.rr$studyVar)
databar <- varianzas[rowstoplot, colstoplot]
rownames(databar) <- c("G.R&R", "Repeat", "Reprod", "Part2Part")
plot6<- lattice::barchart(databar,
freq = FALSE,
grid = TRUE,
par.settings = list(axis.text = list(cex = 0.6),
par.ylab.text = list(cex = 0.8),
par.main.text = list(cex = 0.85)),
ylab = list("Percent", fontsize = 8),
panel = function(...) {
lattice::panel.barchart(...)
lattice::panel.abline(h = 0)
lattice::panel.abline(h = c(10, 30),
lty = 2,
col = "gray")
},
auto.key = list(text = klabels,
cex = 0.8,
columns = length(colstoplot),
space = "bottom",
rectangles = TRUE,
points = FALSE, adj = 1,
rep = FALSE),
stack = FALSE,
horizontal = FALSE,
main = list("Components of Variation", fontsize = 14))
plot6
## Control Charts
data.xrange <- aggregate(as.formula(paste(var, "~", appr, "+", part)),
data = data,
function(x) {
max(x) - min(x)
})
ar <- mean(data.xrange[[var]])
## Mean chart
vp.ccMean <- grid::viewport(name = "ccMean", layout.pos.row = 3,
layout.pos.col = 1)
xbar <- mean(data[[var]], na.rm = TRUE)
ucl <- xbar + (3/(ss.cc.getd2(n)*sqrt(n)))*ar
lcl <- xbar - (3/(ss.cc.getd2(n)*sqrt(n)))*ar
glimits <- c(min(range(data.xbar[[var]])[1], lcl),
max(range(data.xbar[[var]])[2], ucl)) +
c(-1, 1)*0.1*diff(range(data.xbar[[var]]))
plot4 <- lattice::xyplot(as.formula(paste(var, "~", part, "|", appr)),
data = data.xbar,
pch = 16,
par.settings = list(axis.text = list(cex = 1.1),
par.xlab.text=list(cex = 1.2),
par.ylab.text=list(cex = 1.2),
par.main.text=list(cex = 1.5)),
par.strip.text = list(cex = 1.3),
main = expression(bold(bar(x)*" Chart by "*appr)),
grid = TRUE,
layout = c(b, 1),
type = "b",
ylim = glimits,
panel = function(...) {
lattice::panel.xyplot(...,lwd = 2,cex = 1.2)
lattice::panel.abline(h = xbar, lty = 2,lwd=3)
lattice::panel.abline(h = ucl, col = "red3",lwd = 2)
lattice::panel.abline(h = lcl, col = "red3",lwd = 2)
}
)
plot4
this.d3 <- ss.cc.getd3(n)
this.d2 <- ss.cc.getd2(n)
rlimits <- c(max(ar*(1 - 3*(this.d3/(this.d2))), 0),
ar*(1 + 3*(this.d3/(this.d2))))
glimits <- c(min(range(data.xrange[[var]])[1], rlimits[1]),
max(range(data.xrange[[var]])[2], rlimits[2])) +
c(-1, 1)*0.1*diff(range(data.xrange[[var]]))
plot5<- lattice::xyplot(as.formula(paste(var, "~", part, "|", appr)),
data = data.xrange, pch = 16,
par.settings = list(axis.text = list(cex = 0.9),
par.xlab.text = list(cex = 1.3),
par.ylab.text = list(cex = 1.3),
par.main.text = list(cex = 1.5)),
par.strip.text = list(cex = 0.9),
main = paste("R Chart by", appr),
grid = TRUE,
layout = c(b, 1),
type = "b",
ylim = glimits,
panel = function(...) {
lattice::panel.xyplot(...,lwd = 2,cex = 1.2)
lattice::panel.abline(h = ar, lty = 2)
lattice::panel.abline(h = rlimits[1], col = "red3")
lattice::panel.abline(h = rlimits[2], col = "red3")
}
)
plot5
Conclusiones
¿Es capaz el sistema de discriminar entre los distintos operarios y elementos?
Como hemos podido observar en la tabla anova, el p-valor del elemento es inferior al 0.05, lo que nos indica que hay diferencias significativas entre ellos. Pero ocurre lo contrario en el caso de los operarios, ya que no se rechaza la hipótesis nula, lo que indica que no hay diferencias entre operarios. Por tanto, podemos decir que nuestro sistema es capaz de discriminar entre elementos pero no entre los operarios.
¿Hay algún elemento que presente una mayor variabilidad entre sus mediciones, es decir, existe algún elemento no reproducible?
Para dar respuesta podemos ver el gráfico de Distancia by Elemento, que representa las observaciones de cada operario para cada uno de los elementos. Se aprecia como en el elemento 3, hay una mayor variabilidad entre los valores medidos lo que indica que ese elemento no resulta reproducible, debido a la distinta medición del mismo elemento por distintos operarios.
¿Hay problemas de repetitividad?
El gráfico R Chart by Operario nos muestra para cada operario el rango de sus mediciones para los diferentes elementos. En nuestro caso, los operarios numero 3, 5, 8, 10 y 16 presentan mucha variabilidad en las mediciones, lo que es una muestra de que hay casos en los que tenemos problemas de repetitividad.
En conclusión, ¿es fiable el sistema de medición?
Como observamos en la columna %Contrib en el análisis realizado, la componente Total Gage R&R contribuye en un 14.20% en la variación total, superando el 9% que se utiliza como regla de decisión, que denota que el sistema es inaceptable y debe ser mejorado.
En términos de %Studyvar, el porcentaje es superior al 30% propuesto, lo que nos indica que el sistema no es fiable.
Finalmente, habiendo realizado el análisis y estudio de los gráficos, se puede concluir que existen problemas de repetitividad y reproducibilidad. Por lo tanto el sistema de medida no es fiable y habría que tratar de mejorarlo, estudiando si el fallo proviene de la toma de los datos por parte operarios. Si fuese caso, una posible solución sería la creación de protocolos de medida estandarizados.
Realizado por: Data Ghosts