Nothing
##############################################################
##################### gageRR - Clase #########################
##############################################################
# gageRR.c ----
#' @title gageRR-class: Class `gageRR`
#' @description R6 Class for Gage R&R (Repeatability and Reproducibility) Analysis
#' @field X Data frame containing the measurement data.
#' @field ANOVA List containing the results of the Analysis of Variance (ANOVA) for the gage study.
#' @field RedANOVA List containing the results of the reduced ANOVA.
#' @field method Character string specifying the method used for the analysis (e.g., \code{`crossed`}, \code{`nested`}).
#' @field Estimates List of estimates including variance components, repeatability, and reproducibility.
#' @field Varcomp List of variance components.
#' @field Sigma Numeric value representing the standard deviation of the measurement system.
#' @field GageName Character string representing the name of the gage.
#' @field GageTolerance Numeric value indicating the tolerance of the gage.
#' @field DateOfStudy Character string representing the date of the gage R&R study.
#' @field PersonResponsible Character string indicating the person responsible for the study.
#' @field Comments Character string for additional comments or notes about the study.
#' @field b Factor levels for operator.
#' @field a Factor levels for part.
#' @field y Numeric vector or matrix containing the measurement responses.
#' @field facNames Character vector specifying the names of the factors (e.g., \code{`Operator`}, \code{`Part`}).
#' @field numO Integer representing the number of operators.
#' @field numP Integer representing the number of parts.
#' @field numM Integer representing the number of measurements per part-operator combination.
#' @examples
#' #create gageRR-object
#' gdo <- gageRRDesign(Operators = 3, Parts = 10, Measurements = 3, randomize = FALSE)
#' #vector of responses
#' y <- c(0.29,0.08, 0.04,-0.56,-0.47,-1.38,1.34,1.19,0.88,0.47,0.01,0.14,-0.80,
#' -0.56,-1.46, 0.02,-0.20,-0.29,0.59,0.47,0.02,-0.31,-0.63,-0.46,2.26,
#' 1.80,1.77,-1.36,-1.68,-1.49,0.41,0.25,-0.11,-0.68,-1.22,-1.13,1.17,0.94,
#' 1.09,0.50,1.03,0.20,-0.92,-1.20,-1.07,-0.11, 0.22,-0.67,0.75,0.55,0.01,
#' -0.20, 0.08,-0.56,1.99,2.12,1.45,-1.25,-1.62,-1.77,0.64,0.07,-0.15,-0.58,
#' -0.68,-0.96,1.27,1.34,0.67,0.64,0.20,0.11,-0.84,-1.28,-1.45,-0.21,0.06,
#' -0.49,0.66,0.83,0.21,-0.17,-0.34,-0.49,2.01,2.19,1.87,-1.31,-1.50,-2.16)
#'
#' #appropriate responses
#' gdo$response(y)
#' # perform and gageRR
#' gdo <- gageRR(gdo)
#'
#' # Using the plots
#' gdo$plot()
gageRR.c <- R6Class("gageRR.c",
public = list(
X = NULL,
ANOVA = NULL,
RedANOVA = NULL,
method = NULL,
Estimates = NULL,
Varcomp = NULL,
Sigma = NULL,
GageName = NULL,
GageTolerance = NULL,
DateOfStudy = NULL,
PersonResponsible = NULL,
Comments = NULL,
b = NULL,
a = NULL,
y = NULL,
facNames = NULL,
numO = NULL,
numP = NULL,
numM = NULL,
#' @description Initialize the fiels of the \code{gageRR} object
#' @param X Data frame containing the measurement data.
#' @param ANOVA List containing the results of the Analysis of Variance (ANOVA) for the gage study.
#' @param RedANOVA List containing the results of the reduced ANOVA.
#' @param method Character string specifying the method used for the analysis (e.g., "crossed", "nested").
#' @param Estimates List of estimates including variance components, repeatability, and reproducibility.
#' @param Varcomp List of variance components.
#' @param Sigma Numeric value representing the standard deviation of the measurement system.
#' @param GageName Character string representing the name of the gage.
#' @param GageTolerance Numeric value indicating the tolerance of the gage.
#' @param DateOfStudy Character string representing the date of the gage R&R study.
#' @param PersonResponsible Character string indicating the person responsible for the study.
#' @param Comments Character string for additional comments or notes about the study.
#' @param b Factor levels for operator.
#' @param a Factor levels for part.
#' @param y Numeric vector or matrix containing the measurement responses.
#' @param facNames Character vector specifying the names of the factors (e.g., "Operator", "Part").
#' @param numO Integer representing the number of operators.
#' @param numP Integer representing the number of parts.
#' @param numM Integer representing the number of measurements per part-operator combination.
initialize = function(X, ANOVA = NULL, RedANOVA = NULL, method = NULL, Estimates = NULL, Varcomp = NULL,
Sigma = NULL, GageName = NULL, GageTolerance = NULL, DateOfStudy = NULL,
PersonResponsible = NULL, Comments = NULL, b = NULL, a = NULL, y = NULL,
facNames = NULL, numO = NULL, numP = NULL, numM = NULL) {
self$X <- X
self$ANOVA <- ANOVA
self$RedANOVA <- RedANOVA
self$method <- method
self$Estimates <- Estimates
self$Varcomp <- Varcomp
self$Sigma <- Sigma
self$GageName <- GageName
self$GageTolerance <- GageTolerance
self$DateOfStudy <- DateOfStudy
self$PersonResponsible <- PersonResponsible
self$Comments <- Comments
self$b <- b
self$a <- a
self$y <- y
self$facNames <- facNames
self$numO <- numO
self$numP <- numP
self$numM <- numM
},
#' @description Return the data frame containing the measurement data (\code{X})
print = function() {
print(as.data.frame(self$X))
},
#' @description Return a subset of the data frame that containing the measurement data (\code{X})
#' @param i The i-position of the row of \code{X}.
#' @param j The j-position of the column of \code{X}.
subset = function(i, j) {
return(self$X[i, j])
},
#' @description Summarize the information of the fields of the \code{gageRR} object.
summary = function() {
if (all(is.na(self$X$Measurement))) {
cat("Gage R&R Summary\n")
cat("-----------------\n")
cat("Method: ", self$method, "\n")
cat("Sigma: ", self$Sigma, "\n")
cat("Gage Name: ", self$GageName, "\n")
cat("Gage Tolerance: ", self$GageTolerance, "\n")
cat("Date of Study: ", self$DateOfStudy, "\n")
cat("Person Responsible: ", self$PersonResponsible, "\n")
cat("Comments: ", self$Comments, "\n")
cat("Operators: ", self$numO, "\n")
cat("Parts: ", self$numP, "\n")
cat("Measurements per Part: ", self$numM, "\n")
} else {
cat("\n")
cat("Operators:\t", self$numO, "\tParts:\t", self$numP, "\n")
cat("Measurements:\t", self$numM, "\tTotal:\t", nrow(self$X), "\n")
cat("----------")
cat("\n")
gageRR(self, method = self$method)
}
return(invisible(self))
},
#' @description Get or get the response for a \code{gageRRDesign} object.
get.response = function() {
return(self$X$Measurement)
},
#' @description Set the response for a \code{gageRRDesign} object.
#' @param value New response vector.
response = function(value) {
self$X$Measurement = value
},
#' @description Methods for function \code{names} in Package \code{base}.
names = function() {
return(names(as.data.frame(self$X)))
},
#' @description Methods for function \code{as.data.frame} in Package \code{base}.
as.data.frame = function() {
return(as.data.frame(self$X))
},
#' @description Get the \code{tolerance} for an object of class \code{gageRR}.
get.tolerance = function() {
return(unlist(self$GageTolerance))
},
#' @description Set the \code{tolerance} for an object of class \code{gageRR}.
#' @param value A data.frame or vector for the new value of tolerance.
set.tolerance = function(value) {
if (!is.numeric(value))
stop("GageTolerance needs to be numeric")
self$GageTolerance = value
return(self)
},
#' @description Get the \code{sigma} for an object of class \code{gageRR}.
get.sigma = function() {
return(unlist(self$Sigma))
},
#' @description Set the \code{sigma} for an object of class \code{gageRR}.
#' @param value Valor of \code{sigma}
set.sigma = function(value) {
if (!is.numeric(value))
stop("Sigma needs to be numeric")
self$Sigma = value
return(self)
},
#' @description This function creates a customized plot using the data from the \code{gageRR.c} object.
#' @param main Character string specifying the title of the plot.
#' @param xlab A character string for the x-axis label.
#' @param ylab A character string for the y-axis label.
#' @param col A character string or vector specifying the color(s) to be used for the plot elements.
#' @param lwd A numeric value specifying the line width of plot elements
#' @param fun Function to use for the calculation of the interactions (e.g., \code{mean}, \code{median}). Default is \code{mean}.
#' @examples
#' # Create gageRR-object
#' gdo = gageRRDesign(Operators = 3, Parts = 10, Measurements = 3, randomize = FALSE)
#' # Vector of responses
#' y = c(0.29,0.08, 0.04,-0.56,-0.47,-1.38,1.34,1.19,0.88,0.47,0.01,0.14,-0.80,
#' -0.56,-1.46, 0.02,-0.20,-0.29,0.59,0.47,0.02,-0.31,-0.63,-0.46,2.26,
#' 1.80,1.77,-1.36,-1.68,-1.49,0.41,0.25,-0.11,-0.68,-1.22,-1.13,1.17,0.94,
#' 1.09,0.50,1.03,0.20,-0.92,-1.20,-1.07,-0.11, 0.22,-0.67,0.75,0.55,0.01,
#' -0.20, 0.08,-0.56,1.99,2.12,1.45,-1.25,-1.62,-1.77,0.64,0.07,-0.15,-0.58,
#' -0.68,-0.96,1.27,1.34,0.67,0.64,0.20,0.11,-0.84,-1.28,-1.45,-0.21,0.06,
#' -0.49,0.66,0.83,0.21,-0.17,-0.34,-0.49,2.01,2.19,1.87,-1.31,-1.50,-2.16)
#'
#' # Appropriate responses
#' gdo$response(y)
#' # Perform and gageRR
#' gdo <- gageRR(gdo)
#'
#' gdo$plot()
plot = function(main=NULL, xlab=NULL, ylab=NULL, col, lwd, fun = mean){
gdo <- self
yName <- gdo$facNames[1]
aName <- gdo$facNames[2]
bName <- gdo$facNames[3]
abName <- paste(aName, ":", bName, sep = "")
if (missing(col))
col <- 2:(length(unique(gdo$b)) + 1)
if (missing(lwd))
lwd <- 1
temp <- NULL
Source <- names(gdo$Varcomp)
VarComp <- round(as.numeric(gdo$Varcomp), 3)
Contribution <- round(as.numeric(gdo$Varcomp) / as.numeric(gdo$Varcomp[length(gdo$Varcomp)]), 3)
VarComp <- t(data.frame(gdo$Varcomp))
VarCompContrib <- VarComp / gdo$Varcomp$totalVar
Stdev <- sqrt(VarComp)
StudyVar <- Stdev * gdo$Sigma
StudyVarContrib <- StudyVar / StudyVar["totalVar", ]
if ((length(gdo$GageTolerance) > 0) && (gdo$GageTolerance > 0)) {
ptRatio <- StudyVar / gdo$GageTolerance
temp <- data.frame(VarComp, VarCompContrib, Stdev, StudyVar, StudyVarContrib, ptRatio)
contribFrame <- data.frame(VarCompContrib, StudyVarContrib, ptRatio)
names(temp)[6] <- c("P/T Ratio")
row.names(temp) <- c(Source)
SNR <- sqrt(2 * (temp["bTob", "VarComp"] / temp["totalRR", "VarComp"]))
} else {
temp <- data.frame(VarComp, VarCompContrib, Stdev, StudyVar, StudyVarContrib)
contribFrame <- data.frame(VarCompContrib, StudyVarContrib)
}
bTob <- paste(bName, "To", bName, sep = "")
Source[Source == "bTob"] <- bTob
row.names(contribFrame) <- Source
if (gdo$method == "crossed")
contribFrame <- contribFrame[-match(c("totalVar", "a", "a_b"), row.names(temp)), ]
else contribFrame <- contribFrame[-match(c("totalVar"), row.names(temp)), ]
numBars <-ncol(contribFrame)
contrib_df <- as.data.frame(contribFrame)
contrib_df$component <- rownames(contribFrame)
contrib_df <- contrib_df %>% rownames_to_column(var = "Source") %>% filter(Source != "totalVar")
ymax <- max(max(contribFrame))
main1 <- NA
contribFrame_long <- as.data.frame(contribFrame)
contribFrame_long$Component <- rownames(contribFrame_long)
contribFrame_long <- tidyr::gather(contribFrame_long, key = "Metric", value = "Value", -Component)
# 1. Components of Variation --------------------------------------------------
p1 <- ggplot(contribFrame_long, aes(x = Component, y = Value, fill = Metric)) +
geom_bar(stat = "identity", position = "dodge") +
labs(title = ifelse(is.null(main[1]), "Components of Variation", main[1]),
x = ifelse(is.null(xlab[1]), "Component", xlab[1]),
y = ifelse(is.null(ylab[1]), "", ylab[1])) +
theme_bw() +
scale_fill_manual(values = col[1:nlevels(factor(contribFrame_long$Metric))]) +
theme(legend.position = "top",
legend.background = element_rect(fill = "white", colour = "black"),
legend.key.size = unit(0.3, "cm"), # reduce the size of the legend key
legend.text = element_text(size = 6), # reduce the size of the legend text
legend.box.spacing = unit(0.1, 'cm'),
legend.title = element_blank(),
plot.title = element_text(hjust = 0.5)
)
# ----------------------
if (gdo$method == "crossed") {
# 2. Measurement by part ------------------------------------------------------
main2 <- NA
if (missing(main) || is.null(main[2]))
main2 <- paste(yName, "by", bName)
else main2 <- main[2]
xlab2 <- NA
if (missing(xlab) || is.null(xlab[2]))
xlab2 <- bName
else xlab2 <- xlab[2]
ylab2 <- NA
if (missing(ylab) || is.null(ylab[2]))
ylab2 <- yName
else ylab2 <- ylab[2]
p2 <- suppressWarnings(
ggplot(gdo$X, aes_string(x = bName, y = yName)) +
geom_boxplot() +
stat_summary(fun = median, geom = "line", aes(group = 1), color = "red", linewidth = lwd) +
stat_summary(fun = median, geom = "point", color = "red") +
labs(title = ifelse(is.null(main2), paste(yName, "by", bName), main2),
x = ifelse(is.null(xlab2), bName, xlab2),
y = ifelse(is.null(ylab2), yName, ylab2)) +
theme_bw() +
theme(plot.title = element_text(hjust = 0.5))
)
# 3. Measurement by operator --------------------------------------------------
main3 = NA
if (missing(main) || is.null(main[3]))
main3 = paste(yName, "by", aName)
else main3 = main[3]
xlab3 = NA
if (missing(xlab) || is.null(xlab[3]))
xlab3 = aName
else xlab3 = xlab[3]
ylab3 = NA
if (missing(ylab) || is.null(ylab[3]))
ylab3 = yName
else ylab3 = ylab[3]
col_op<-2:(length(unique(gdo$a)) + 1)
p3 <- ggplot(gdo$X, aes_string(x = aName, y = yName)) +
geom_boxplot(aes(fill = factor(gdo$X[, 3]))) +
stat_summary(fun = median, geom = "line", aes(group = 1), color = "red", linewidth = lwd) +
stat_summary(fun = median, geom = "point", color = "red", size = 3) +
labs(title = ifelse(is.null(main[3]), paste(yName, "by", aName), main[3]),
x = ifelse(is.null(xlab[3]), aName, xlab[3]),
y = ifelse(is.null(ylab[3]), yName, ylab[3]),
fill = "Factor") +
theme_bw() +
scale_fill_manual(values = col_op) +
theme(plot.title = element_text(hjust = 0.5), legend.position='none')
# 4. X_mean Chart -------------------------------------------------------------------------------
agg = aggregate(gdo$X[, yName], list(gdo$X[, aName], gdo$X[, bName]), FUN = mean)
tab = table(agg[, 2])
sgSize = tab[1]
aggSd = aggregate(gdo$X[, yName], list(gdo$X[, bName], gdo$X[, aName]), FUN = sd)
tab = table(aggSd[, 2])
sm = mean(aggSd[, 3])
aggMean = aggregate(gdo$X[, yName], list(gdo$X[, bName], gdo$X[, aName]), FUN = mean)
xm = mean(agg[, 3])
UCL = xm + ((3 * sm)/(.c4(sgSize) * sqrt(sgSize)))
LCL = xm - ((3 * sm)/(.c4(sgSize) * sqrt(sgSize)))
values = c(UCL, xm, LCL)
p4 <- ggplot(data.frame(x = 1:length(aggMean[, 3]), y = aggMean[, 3]), aes(x, y)) +
geom_point(shape = 1) +
geom_line() +
geom_hline(yintercept = xm, color = 3) + # lC-nea xm
geom_hline(yintercept = UCL, color = "red") + # lC-nea UCL
geom_hline(yintercept = LCL, color = "red") + # lC-nea LCL
labs(x = aName, y = expression(bar(x))) + # tC-tulos ejes
ggtitle(expression(paste(bar(x), " Chart"))) + # tC-tulo
geom_vline(xintercept = cumsum(tab) - 0.5, linetype = "dashed") + # divide categorC-as A,B C
scale_x_continuous(breaks = cumsum(tab), labels = names(tab)) + # y pone los nombres de las secciones
theme_bw() +
theme(plot.title = element_text(hjust = 0.5)) +
scale_y_continuous(expand = c(0, 0),
sec.axis = sec_axis(~ ., breaks = c(UCL, xm, LCL),
labels= c(paste("UCL =", round(UCL, 2)),
paste("X_mean =", round(xm,2)),
paste("UCL =", round(UCL, 2))
) )) +
theme(axis.text.y.right = element_text(size = 8))
# 5. Interaction Operator ------------------------------------------------------------------
main4 <- NA
if (missing(main) || is.null(main[4]))
main4 <- paste("Interaction", abName)
else main4 <- main[4]
xlab4 <- NA
if (missing(xlab) || is.null(xlab[4]))
xlab4 <- colnames(gdo$X)[4]
else xlab4 <- xlab[4]
ylab4 <- NA
if (missing(ylab) || is.null(ylab[4]))
ylab4 <- paste(as.character(body(match.fun(fun)))[2], "of", colnames(gdo$X)[5])
else ylab4 <- ylab[4]
p5 <- .aip(gdo$X[, 4], gdo$X[, 3], response = gdo$X[, 5], xlab = xlab4, ylab = ylab4, title = "Interaction Operator: Part", legend = TRUE,col = col, type = "b", plot = FALSE)
# 6. R chart -------------------------------------------------
D3 <- c(0, 0, 0, 0, 0, 0.076, 0.136, 0.184, 0.223, 0.256, 0.284, 0.308, 0.329, 0.348)
D4 <- c(0, 3.267, 2.574, 2.282, 2.115, 2.004, 1.924, 1.864, 1.816, 1.777, 1.744, 1.716, 1.692, 1.671, 1.652)
helpRange = function(x) {
return(diff(range(x)))
}
aggForLimits <- aggregate(gdo$X[, yName], list(gdo$X[, aName], gdo$X[, bName]), FUN = helpRange)
Rm <- mean(aggForLimits[, 3])
sgSize <- length(unique(gdo$X[, bName]))
UCL <- D4[sgSize] * Rm
LCL <- D3[sgSize] * Rm
agg <- aggregate(gdo$X[, yName], list(gdo$X[, bName], gdo$X[, aName]), FUN = helpRange)
agg$Group.1 <- factor(agg$Group.1, levels = unique(agg$Group.1))
tab = table(agg[, 2])
sgSize = tab[1]
p6 <- ggplot(data.frame(x = 1:length(agg[, 3]), y = agg[, 3]), aes(x, y)) +
geom_point(shape = 1) +
geom_line() +
geom_hline(yintercept = Rm, color = 3) + # lC-nea xm
geom_hline(yintercept = UCL, color = "red") + # lC-nea UCL
geom_hline(yintercept = LCL, color = "red") + # lC-nea LCL
labs(x = aName, y = "R") + # tC-tulos ejes
ggtitle("R Chart") + # tC-tulo
geom_vline(xintercept = cumsum(tab) - 0.5, linetype = "dashed") + # divide categorC-as A,B C
scale_x_continuous(breaks = cumsum(tab), labels = names(tab)) + # y pone los nombres de las secciones
theme_bw() +
theme(plot.title = element_text(hjust = 0.5)) +
scale_y_continuous(expand = c(0, 0),
sec.axis = sec_axis(~ ., breaks = c(UCL, Rm, LCL),
labels= c(paste("UCL =", round(UCL, 2)),
paste("R_mean =", round(Rm,2)),
paste("UCL =", round(UCL, 2))
) )) +
theme(axis.text.y.right = element_text(size = 8))
# UNION PLOTS -------------
p <- p1 + p3 + p5$plot + p2 + p4 + p6 + plot_layout(nrow = 3, byrow = FALSE)
}
if(gdo$method == "nested"){
# 2. Measurement by Part within operator --------------
main2 = NA
if (missing(main) || is.null(main[2]))
main2 = paste(yName, "By", bName, "Within", aName)
else main2 = main[2]
xlab2 = NA
if (missing(xlab) || is.na(xlab[2]))
xlab2 = NA
else xlab2 = xlab[2]
ylab2 = NA
if (missing(ylab) || is.na(ylab[2]))
ylab2 = yName
else ylab2 = ylab[2]
agg = aggregate(gdo$X[, yName], list(gdo$X[, bName], gdo$X[, aName]), FUN = function(x){return(x)})
plot(1:nrow(agg), main = main2, xlab = xlab2, ylab = ylab2, ylim = range(agg[, 3]), axes = FALSE)
axis(2)
box()
label2 = ""
for (i in 1:nrow(agg)) {
points(rep(i, length(agg[i, 3])), agg[i, 3])
axis(1, at = i, labels = agg[i, 1])
if (agg[i, 2] != label2) {
axis(1, at = i, labels = agg[i, 2], line = 1, tick = FALSE)
label2 = agg[i, 2]
}
}
aggm = aggregate(gdo$X[, yName], list(gdo$X[, bName], gdo$X[, aName]), FUN = mean)
lines(aggm[, 3])
points(aggm[, 3], pch = 13, cex = 2)
# 3. Box Blot Measurement by Operator -----------------
main3 = NA
if (missing(main) || is.na(main[3]))
main3 = paste(yName, "by", aName)
else main3 = main[3]
xlab3 = NA
if (missing(xlab) || is.na(xlab[3]))
xlab3 = aName
else xlab3 = xlab[3]
ylab3 = NA
if (missing(ylab) || is.na(ylab[3]))
ylab3 = yName
else ylab3 = ylab[3]
col_op<-2:(length(unique(gdo$a)) + 1)
p3 <- ggplot(gdo$X, aes_string(x = aName, y = yName)) +
geom_boxplot(aes(fill = factor(gdo$X[, 3]))) +
stat_summary(fun = median, geom = "line", aes(group = 1), color = "red", linewidth = lwd) +
stat_summary(fun = median, geom = "point", color = "red", size = 3) +
labs(title = ifelse(is.null(main[3]), paste(yName, "by", aName), main[3]),
x = ifelse(is.null(xlab[3]), aName, xlab[3]),
y = ifelse(is.null(ylab[3]), yName, ylab[3]),
fill = "Factor") +
theme_bw() +
scale_fill_manual(values = col_op) +
theme(plot.title = element_text(hjust = 0.5), legend.position='none')
# 4. X_mean Chart ----------------------
agg = aggregate(gdo$X[, yName], list(gdo$X[, aName], gdo$X[, bName]), FUN = mean)
tab = table(agg[, 2])
sgSize = tab[1]
aggSd = aggregate(gdo$X[, yName], list(gdo$X[, bName], gdo$X[, aName]), FUN = sd)
tab = table(aggSd[, 2])
sm = mean(aggSd[, 3])
aggMean = aggregate(gdo$X[, yName], list(gdo$X[, bName], gdo$X[, aName]), FUN = mean)
xm = mean(agg[, 3])
UCL = xm + ((3 * sm)/(.c4(sgSize) * sqrt(sgSize)))
LCL = xm - ((3 * sm)/(.c4(sgSize) * sqrt(sgSize)))
values = c(UCL, xm, LCL)
p4 <- ggplot(data.frame(x = 1:length(aggMean[, 3]), y = aggMean[, 3]), aes(x, y)) +
geom_point(shape = 1) +
geom_line() +
geom_hline(yintercept = xm, color = 3) + # lC-nea xm
geom_hline(yintercept = UCL, color = "red") + # lC-nea UCL
geom_hline(yintercept = LCL, color = "red") + # lC-nea LCL
labs(x = aName, y = expression(bar(x))) + # tC-tulos ejes
ggtitle(expression(paste(bar(x), " Chart"))) + # tC-tulo
geom_vline(xintercept = cumsum(tab) - 0.5, linetype = "dashed") + # divide categorC-as A,B C
scale_x_continuous(breaks = cumsum(tab), labels = names(tab)) + # y pone los nombres de las secciones
theme_minimal() +
theme(plot.title = element_text(hjust = 0.5)) +
scale_y_continuous(expand = c(0, 0),
sec.axis = sec_axis(~ ., breaks = c(UCL, xm, LCL),
labels= c(paste("UCL =", round(UCL, 2)),
paste("X_mean =", round(xm,2)),
paste("UCL =", round(UCL, 2))
) )) +
theme(axis.text.y.right = element_text(size = 8))
# 5. R Chart --------------------------------------
D3 = c(0, 0, 0, 0, 0, 0.076, 0.136, 0.184, 0.223, 0.256, 0.284, 0.308, 0.329, 0.348)
D4 = c(0, 3.267, 2.574, 2.282, 2.115, 2.004, 1.924, 1.864, 1.816, 1.777, 1.744, 1.716, 1.692, 1.671, 1.652)
helpRange = function(x) {
return(diff(range(x)))
}
aggForLimits = aggregate(gdo$X[, yName], list(gdo$X[, aName], gdo$X[, bName]), FUN = helpRange)
Rm = mean(aggForLimits[, 3])
UCL = D4[sgSize] * Rm
LCL = D3[sgSize] * Rm
agg = aggregate(gdo$X[, yName], list(gdo$X[, bName], gdo$X[, aName]), FUN = helpRange)
tab = table(agg[, 2])
sgSize = tab[1]
p5 <- ggplot(data.frame(x = 1:length(agg[, 3]), y = agg[, 3]), aes(x, y)) +
geom_point(shape = 1) +
geom_line() +
geom_hline(yintercept = Rm, color = 3) + # lC-nea xm
geom_hline(yintercept = UCL, color = "red") + # lC-nea UCL
geom_hline(yintercept = LCL, color = "red") + # lC-nea LCL
labs(x = aName, y = "R") + # tC-tulos ejes
ggtitle("R Chart") + # tC-tulo
geom_vline(xintercept = cumsum(tab) - 0.5, linetype = "dashed") + # divide categorC-as A,B C
scale_x_continuous(breaks = cumsum(tab), labels = names(tab)) + # y pone los nombres de las secciones
theme_minimal() +
theme(plot.title = element_text(hjust = 0.5)) +
scale_y_continuous(expand = c(0, 0),
sec.axis = sec_axis(~ ., breaks = c(UCL, Rm, LCL),
labels= c(paste("UCL =", round(UCL, 2)),
paste("R_mean =", round(Rm,2)),
paste("UCL =", round(UCL, 2))
) )) +
theme(axis.text.y.right = element_text(size = 8))
# UNION PLOTS -----------------------
p <- p1 / (p2 + p3) / (p4 + p5) # p2 falta cambiar a ggplot2
}
show(p)
invisible(list(plot = p))
},
#' @description The data from an object of class \code{gageRR} can be analyzed by running `Error Charts` of the individual deviations from the accepted rference values. These `Error Charts` are provided by the function \code{errorPlot}.
#' @param main a main title for the plot.
#' @param xlab A character string for the x-axis label.
#' @param ylab A character string for the y-axis label.
#' @param col Plotting color.
#' @param pch An integer specifying a symbol or a single character to be used as the default in plotting points.
#' @param ylim The y limits of the plot.
#' @param legend A logical value specifying whether a legend is plotted automatically. By default legend is set to `TRUE`.
#' @examples
#' # Create gageRR-object
#' gdo = gageRRDesign(Operators = 3, Parts = 10, Measurements = 3, randomize = FALSE)
#' # Vector of responses
#' y = c(0.29,0.08, 0.04,-0.56,-0.47,-1.38,1.34,1.19,0.88,0.47,0.01,0.14,-0.80,
#' -0.56,-1.46, 0.02,-0.20,-0.29,0.59,0.47,0.02,-0.31,-0.63,-0.46,2.26,
#' 1.80,1.77,-1.36,-1.68,-1.49,0.41,0.25,-0.11,-0.68,-1.22,-1.13,1.17,0.94,
#' 1.09,0.50,1.03,0.20,-0.92,-1.20,-1.07,-0.11, 0.22,-0.67,0.75,0.55,0.01,
#' -0.20, 0.08,-0.56,1.99,2.12,1.45,-1.25,-1.62,-1.77,0.64,0.07,-0.15,-0.58,
#' -0.68,-0.96,1.27,1.34,0.67,0.64,0.20,0.11,-0.84,-1.28,-1.45,-0.21,0.06,
#' -0.49,0.66,0.83,0.21,-0.17,-0.34,-0.49,2.01,2.19,1.87,-1.31,-1.50,-2.16)
#'
#' # Appropriate responses
#' gdo$response(y)
#' # Perform and gageRR
#' gdo <- gageRR(gdo)
#'
#' gdo$errorPlot()
errorPlot = function(main, xlab, ylab, col, pch, ylim, legend = TRUE){
x <- self
ops = length(unique(x$subset(j=3)))
pts = length(unique(x$subset(j=4)))
n = length(x$subset(j=5))/pts/ops
ref = mean(x$get.response())
val = x$as.data.frame()
dat = val
if (missing(xlab))
xlab = paste(names(val)[4], "s", sep = "")
if (missing(ylab))
ylab = "Error"
if (missing(main))
main = paste("Error plot")
if (missing(pch))
pch = 1:ops
if (length(pch) < ops)
pch = rep(pch, ops)
if (missing(col))
col = rainbow(ops)
if (length(col) < ops)
col = rep(col, ops)
if (missing(ylim)) {
max_y = numeric(pts)
min_y = numeric(pts)
for (i in 1:pts) {
dat = subset(val, val[, 4] == unique(x$subset(j=4))[i])
max_y[i] = max(dat[, 5] - mean(dat[, 5]))
min_y[i] = min(dat[, 5] - mean(dat[, 5]))
}
ylim = c(-1.25 * abs(min(min_y)), abs(max(max_y)))
}
j <- 0
plot_data <- data.frame()
legend_labels <- unique(x$subset(j = 3))
names(legend_labels) <- paste0("Group ", 1:length(legend_labels))
for (i in 1:pts) {
dat <- subset(val, val[, 4] == unique(x$subset(j=4))[i])
dat <- dat[order(dat[, 3]), ]
j <- j + 1
for (k in 1:ops) {
subset_data <- data.frame(
x = (j + 1):(j + n),
y = (dat[(((k * n) - n + 1):(k * n)), 5] - mean(dat[, 5])),
group = rep(i, n),
shape_color = factor(paste0("Group ", k), levels = paste0("Group ", 1:ops)) # Mantener el orden de los grupos
)
plot_data <- rbind(plot_data, subset_data)
j <- j + n
}
}
p <- ggplot(plot_data, aes(x = x, y = y, color = shape_color, shape = shape_color, group = group)) +
geom_point() +
geom_line() +
labs(
x = xlab,
y = ylab,
title = main,
color = paste(names(val)[3], "(s):", sep = ""), # TÃtulo de la leyenda
shape = paste(names(val)[3], "(s):", sep = "")
) +
scale_color_manual(values = col, labels = as.vector(legend_labels)) + # Etiquetas personalizadas
scale_shape_manual(values = pch, labels = as.vector(legend_labels)) + # Etiquetas personalizadas
theme_classic() +
scale_x_continuous(breaks = seq(1 + (n * ops / 2), pts * n * ops + pts + 1 - (n * ops / 2), length = pts),
labels = unique(x$subset(j=4))) +
ylim(ylim) +
geom_vline(xintercept = seq(1, pts * n * ops + pts + 1, by = n * ops + 1), col = "gray") +
geom_hline(yintercept = 0, col = "gray", linetype = "dashed") +
theme(panel.border = element_rect(colour = "black", fill = NA),
plot.title = element_text(hjust = 0.5,face = "bold"))
if (legend){
p <- p + theme(legend.position="right",legend.background = element_rect(fill = "white", colour = "black"))
}
else{
p <- p + theme(legend.position = "none")
}
show(p)
invisible(list(plot = p))
},
#' @description In a Whiskers Chart, the high and low data values and the average (median) by part-by-operator are plotted to provide insight into the consistency between operators, to indicate outliers and to discover part-operator interactions. The Whiskers Chart reminds of boxplots for every part and every operator.
#' @param main a main title for the plot.
#' @param xlab A character string for the x-axis label.
#' @param ylab A character string for the y-axis label.
#' @param col Plotting color.
#' @param ylim The y limits of the plot.
#' @param legend A logical value specifying whether a legend is plotted automatically. By default legend is set to `TRUE`.
#' @examples
#' # Create gageRR-object
#' gdo = gageRRDesign(Operators = 3, Parts = 10, Measurements = 3, randomize = FALSE)
#' # Vector of responses
#' y = c(0.29,0.08, 0.04,-0.56,-0.47,-1.38,1.34,1.19,0.88,0.47,0.01,0.14,-0.80,
#' -0.56,-1.46, 0.02,-0.20,-0.29,0.59,0.47,0.02,-0.31,-0.63,-0.46,2.26,
#' 1.80,1.77,-1.36,-1.68,-1.49,0.41,0.25,-0.11,-0.68,-1.22,-1.13,1.17,0.94,
#' 1.09,0.50,1.03,0.20,-0.92,-1.20,-1.07,-0.11, 0.22,-0.67,0.75,0.55,0.01,
#' -0.20, 0.08,-0.56,1.99,2.12,1.45,-1.25,-1.62,-1.77,0.64,0.07,-0.15,-0.58,
#' -0.68,-0.96,1.27,1.34,0.67,0.64,0.20,0.11,-0.84,-1.28,-1.45,-0.21,0.06,
#' -0.49,0.66,0.83,0.21,-0.17,-0.34,-0.49,2.01,2.19,1.87,-1.31,-1.50,-2.16)
#'
#' # Appropriate responses
#' gdo$response(y)
#' # Perform and gageRR
#' gdo <- gageRR(gdo)
#'
#' gdo$whiskersPlot()
whiskersPlot = function(main, xlab, ylab, col, ylim, legend = TRUE){
x <- self
ops = length(unique(x$subset(j=3)))
pts = length(unique(x$subset(j=4)))
n = length(x$subset(j=5))/pts/ops
val = x$as.data.frame()
dat = val
if (missing(xlab))
xlab = paste(names(val)[4], "s", sep = "")
if (missing(ylab))
ylab = "Value"
if (missing(main))
main = paste("Whiskers Plot")
if (missing(col))
col = heat.colors(ops)
if (length(col) < ops)
col = rep(col, ops)
if (missing(ylim)) {
max_y = numeric(pts)
min_y = numeric(pts)
for (i in 1:pts) {
dat = subset(val, val[, 4] == unique(x$subset(j=4))[i])
max_y[i] = max(dat[, 5])
min_y[i] = min(dat[, 5])
}
ylim = c(-1.25 * abs(min(min_y)), abs(max(max_y)))
}
j <- 0
plot_data <- data.frame()
legend_labels <- unique(x$subset(j = 3))
for (i in 1:pts) {
dat <- subset(val, val[, 4] == unique(x$subset(j=4))[i])
dat <- dat[order(dat[, 3]), ]
j <- j + 1
for (k in 1:ops) {
subset_data <- data.frame(
x_min = j + 1,
x_max = j + n,
y_min = min(dat[(((k * n) - n + 1):(k * n)), 5]),
y_max = max(dat[(((k * n) - n + 1):(k * n)), 5]),
y_mean = median(dat[(((k * n) - n + 1):(k * n)), 5]),
group = rep(i, n),
fill_color = factor(legend_labels[k], levels = legend_labels) # Asignar directamente las etiquetas correctas
)
plot_data <- rbind(plot_data, subset_data)
j <- j + n
}
}
p <- ggplot(plot_data) +
geom_rect(aes(xmin = x_min, xmax = x_max, ymin = y_min, ymax = y_max, fill = fill_color), color = "black", alpha = 0.5) +
geom_segment(aes(x = x_min, xend = x_max, y = y_mean, yend = y_mean), color = "black", size = 1) +
labs(
x = xlab,
y = ylab,
title = main,
fill = paste(names(val)[3], "(s):", sep = "")
) +
scale_fill_manual(values = col, labels = legend_labels) + # Etiquetas personalizadas
theme_classic() +
scale_x_continuous(breaks = seq(1 + (n * ops / 2), pts * n * ops + pts + 1 - (n * ops / 2), length = pts),
labels = unique(x$subset(j=4))) +
ylim(ylim) +
geom_vline(xintercept = seq(1, pts * n * ops + pts + 1, by = n * ops + 1), col = "gray") +
geom_hline(yintercept = 0, col = "gray", linetype = "dashed") +
theme(panel.border = element_rect(colour = "black", fill = NA),
plot.title = element_text(hjust = 0.5,face = "bold"))
if (legend) {
p <- p + theme(legend.position = "right", legend.background = element_rect(fill = "white", colour = "black"))
} else {
p <- p + theme(legend.position = "none")
}
show(p)
invisible(list(plot = p))
},
#' @description \code{averagePlot} creates all x-y plots of averages by size out of an object of class \code{gageRR}. Therfore the averages of the multiple readings by each operator on each part are plotted with the reference value or overall part averages as the index.
#' @param main a main title for the plot.
#' @param xlab A character string for the x-axis label.
#' @param ylab A character string for the y-axis label.
#' @param col Plotting color.
#' @param single A logical value.If `TRUE` a new graphic device will be opened for each plot. By default \code{single} is set to `FALSE`.
#' @examples
#' # Create gageRR-object
#' gdo = gageRRDesign(Operators = 3, Parts = 10, Measurements = 3, randomize = FALSE)
#' # Vector of responses
#' y = c(0.29,0.08, 0.04,-0.56,-0.47,-1.38,1.34,1.19,0.88,0.47,0.01,0.14,-0.80,
#' -0.56,-1.46, 0.02,-0.20,-0.29,0.59,0.47,0.02,-0.31,-0.63,-0.46,2.26,
#' 1.80,1.77,-1.36,-1.68,-1.49,0.41,0.25,-0.11,-0.68,-1.22,-1.13,1.17,0.94,
#' 1.09,0.50,1.03,0.20,-0.92,-1.20,-1.07,-0.11, 0.22,-0.67,0.75,0.55,0.01,
#' -0.20, 0.08,-0.56,1.99,2.12,1.45,-1.25,-1.62,-1.77,0.64,0.07,-0.15,-0.58,
#' -0.68,-0.96,1.27,1.34,0.67,0.64,0.20,0.11,-0.84,-1.28,-1.45,-0.21,0.06,
#' -0.49,0.66,0.83,0.21,-0.17,-0.34,-0.49,2.01,2.19,1.87,-1.31,-1.50,-2.16)
#'
#' # Appropriate responses
#' gdo$response(y)
#' # Perform and gageRR
#' gdo <- gageRR(gdo)
#'
#' gdo$averagePlot()
averagePlot = function(main, xlab, ylab, col, single = FALSE){
x <- self
ops = length(unique(x$subset(j=3)))
pts = length(unique(x$subset(j=4)))
n = length(x$subset(j=5))/pts/ops
ref = numeric(pts * n)
val = x$as.data.frame()
dat = val
if (missing(xlab))
xlab = "reference"
if (missing(ylab))
ylab = "values"
if (missing(col))
col = 1
if (missing(main))
main = as.vector(paste(names(val)[3], unique(x$subset(j=3))))
scr = TRUE
if (identical(par("mfrow"), as.integer(c(1, 1))) == TRUE)
scr = FALSE
k = 0
m = 1
for (j in 1:pts) {
dat = subset(val, val[, 4] == unique(x$subset(j=4))[j])
ref[(k + 1):(k + n)] = mean(dat[, 5])
k = k + n
}
if (single == TRUE){
plots <- list()
for (i in 1:ops) {
dat <- subset(val, val[, 3] == unique(x$subset(j=3))[i])
dat <- dat[order(dat[, 4]), ]
p <- ggplot(data = dat, aes(x = ref, y = dat[, 5])) +
geom_point(color = col) +
labs(title = main[i], x = xlab, y = ylab) +
theme_classic() +
theme(panel.border = element_rect(colour = "black", fill = NA),
plot.title = element_text(hjust = 0.5,face = "bold"))
plots[[i]] <- p
print(p)
}
invisible(list(plot = plots))
}
else{
plots <- list()
for (i in 1:ops) {
dat <- subset(val, val[, 3] == unique(x$subset(j=3))[i])
dat <- dat[order(dat[, 4]), ]
p <- ggplot(data = dat, aes(x = ref, y = dat[, 5])) +
geom_point(color = col) +
labs(title = main[i], x = xlab, y = ylab) +
theme_classic() +
theme(panel.border = element_rect(colour = "black", fill = NA),
plot.title = element_text(hjust = 0.5,face = "bold"))
plots[[i]] <- p
}
final_plot <- wrap_plots(plots, nrow = .splitDev(ops)[[2]][1], ncol = .splitDev(ops)[[2]][2])
print(final_plot)
invisible(list(plot = final_plot))
}
},
#' @description \code{compPlot} creates comparison x-y plots of an object of class \code{gageRR}. The averages of the multiple readings by each operator on each part are plotted against each other with the operators as indices. This plot compares the values obtained by one operator to those of another.
#' @param main a main title for the plot.
#' @param xlab A character string for the x-axis label.
#' @param ylab A character string for the y-axis label.
#' @param col Plotting color.
#' @param cex.lab The magnification to be used for x and y labels relative to the current setting of cex.
#' @param fun Optional function that will be applied to the multiple readings of each part. fun should be an object of class \code{function} like \code{mean},\code{median}, \code{sum}, etc. By default, \code{fun} is set to `NULL` and all readings will be plotted.
#' @examples
#' # Create gageRR-object
#' gdo = gageRRDesign(Operators = 3, Parts = 10, Measurements = 3, randomize = FALSE)
#' # Vector of responses
#' y = c(0.29,0.08, 0.04,-0.56,-0.47,-1.38,1.34,1.19,0.88,0.47,0.01,0.14,-0.80,
#' -0.56,-1.46, 0.02,-0.20,-0.29,0.59,0.47,0.02,-0.31,-0.63,-0.46,2.26,
#' 1.80,1.77,-1.36,-1.68,-1.49,0.41,0.25,-0.11,-0.68,-1.22,-1.13,1.17,0.94,
#' 1.09,0.50,1.03,0.20,-0.92,-1.20,-1.07,-0.11, 0.22,-0.67,0.75,0.55,0.01,
#' -0.20, 0.08,-0.56,1.99,2.12,1.45,-1.25,-1.62,-1.77,0.64,0.07,-0.15,-0.58,
#' -0.68,-0.96,1.27,1.34,0.67,0.64,0.20,0.11,-0.84,-1.28,-1.45,-0.21,0.06,
#' -0.49,0.66,0.83,0.21,-0.17,-0.34,-0.49,2.01,2.19,1.87,-1.31,-1.50,-2.16)
#'
#' # Appropriate responses
#' gdo$response(y)
#' # Perform and gageRR
#' gdo <- gageRR(gdo)
#'
#' gdo$compPlot()
compPlot = function(main, xlab, ylab, col, cex.lab, fun = NULL){
x <- self
if (missing(xlab))
xlab = ""
if (missing(ylab))
ylab = ""
if (missing(col))
col = 1
ops = length(unique(x$subset(j=3)))
pts = length(unique(x$subset(j=4)))
n = length(x$subset(j=5))/pts/ops
comp = unique(x$subset(j=4))
val = x$as.data.frame()
dat = val
if (identical(fun, NULL) == FALSE)
means = matrix(data = NA, nrow = ops, ncol = pts)
if (identical(fun, NULL))
means = matrix(data = NA, nrow = ops, ncol = n * pts)
if (missing(main))
main = paste("Comparison Plot for", names(val)[3])
if (missing(cex.lab))
cex.lab = 10/ops
plots <- list()
for (i in 1:ops) {
dat <- subset(val, val[, 3] == unique(x$subset(j=3))[i])
if (!is.null(fun)) {
for (j in 1:pts) means[i, j] <- fun(subset(dat, dat[, 4] == unique(dat[, 4])[j])[, 5])
} else {
means[i, ] <- dat[, 5]
}
for (k in 1:ops) {
if (k == i) {
p <- ggplot() +
geom_blank() +
annotate("text", x = 5.5, y = 5, label = unique(x$subset(j=3))[i], size = cex.lab, fontface = "bold") +
theme_void()
plots[[length(plots) + 1]] <- p
} else if (k < i) {
plot_data <- data.frame(x = means[k, ], y = means[i, ])
p <- ggplot(plot_data, aes(x = x, y = y)) +
geom_point(color = col) +
labs(x = xlab, y = ylab) +
theme_classic() +
theme(axis.title.x = element_blank(), axis.title.y = element_blank())
plots[[length(plots) + 1]] <- p
} else {
p <- ggplot() +
geom_blank() +
theme_void()
plots[[length(plots) + 1]] <- p
}
}
}
final_plot <- wrap_plots(plots, nrow = ops, ncol = ops) +
plot_annotation(
title = main,
theme = theme(
plot.title = element_text(hjust = 0.5,face = "bold") # Centrar el tÃtulo
)
)
print(final_plot)
invisible(list(plot = final_plot))
}
)
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.