#' @title get_tests
#' @description checks control chart data for triggering of tests.
#'
#' @param df Dataframe from ggcc_gen.
#' @param avg Calculated average.
#' @param pseudo_sd Calculated pseudo sd.
#'
#' @return returns string indicated which tests were triggered to be used as footer.
get_tests <- function(df, avg, pseudo_sd) {
zones <- as.numeric(scale(df$complaints, center = avg, scale = pseudo_sd))
# last point outside 3 sd range
test1 <- abs(tail(zones, 1)) > 3
# 6 points in a row increasing or decreasing
test3 <- any(sum(tail(diff(df$complaints), 6) > 0) == 6,
sum(tail(diff(df$complaints), 6) < 0) == 6)
# 2 out of last 3 points on same side of 2 sd range
test5 <- any(sum(tail(zones, 3) < -2) > 1,
sum(tail(zones, 3) > 2) > 1)
# 4 out of last 5 points on same side of 1 sd range
test6 <- any(sum(tail(zones, 5) < -1) > 3,
sum(tail(zones, 5) > 1) > 3)
# 8 points greater than 2 sd from center line
test8 <- sum(abs(tail(zones, 8)) > 2) == 8
tests <- paste(c(1, 3, 5, 6, 8)[c(test1, test3, test5, test6, test8)],
collapse = ', ')
paste('Tests triggered :',
ifelse(tests == '', 'None', tests))
}
#' @title ggcc
#'
#' @description Function to produce control charts using ggplot2.
#'
#' @param df Dataframe
#' @param title Appends to Control Chart: title
#' @param clre Boolean to indicate if typical clre chart is being made. Defaults to TRUE
#'
#' @return Returns control chart
#'
#' @export
ggcc <- function(
df,
title,
clre = TRUE
) {
avgr <- round(mean(df$range, na.rm = TRUE), digits = 1)
lclr <- 0
uclr <- round(3.267*avgr, digits = 1)
pseudo_sd <- avgr / 1.128
avg <- round(mean(df$complaints), digits = 1)
lcl <- round(mean(df$complaints) - 3*pseudo_sd, digits = 1)
ucl <- round(mean(df$complaints) + 3*pseudo_sd, digits = 1)
lzb <- round(mean(df$complaints) - 2*pseudo_sd, digits = 1)
uzb <- round(mean(df$complaints) + 2*pseudo_sd, digits = 1)
lzc <- round(mean(df$complaints) - pseudo_sd, digits = 1)
uzc <- round(mean(df$complaints) + pseudo_sd, digits = 1)
test <- get_tests(df = df, avg = avg, pseudo_sd = pseudo_sd)
rects <- data.frame(
ystart = lcl,
yend = ucl
)
rectsr <- data.frame(
ystart = lclr,
yend = uclr
)
format_monyr <- function(x) {
strftime(strptime(paste0(x, '01'), format = '%Y%m%d'), format = '%b%y')
}
# ind_labels <- ifelse(df$test == 0, df$complaints, paste('Test', df$test))
# rl <- split(df, df$reds)
# rl <- rl[!(names(rl) == '0')]
individuals <- ggplot() +
# frequencly lines
geom_line(
data=df,
aes(x = monyr, y = complaints, group = 1),
alpha = 0.4
) +
# frequency points
geom_point(
data=df,
aes(x = monyr, y = complaints, group = 1),
size = 1
) +
#point labels
# geom_text(
# data=df,
# aes(x = monyr, y = complaints, label = ind_labels, colour = count_label == 1),
# vjust = 'inward',
# hjust = 'inward',
# size = 2.5
# ) +
geom_text(
data=df,
aes(x = monyr, y = complaints, label = complaints),
vjust = 'inward',
hjust = 'inward',
size = 2.5
) +
scale_colour_manual(values = setNames(c('black', 'red'), c(F, T))) +
#mean line
geom_hline(
data=df,
aes(yintercept = avg),
color = 'black',
alpha = .5
) +
# LCL line
geom_hline(
data=df,
aes(yintercept = lcl),
color = 'black',
linetype = 'dashed',
alpha = 0.25
) +
# UCL line
geom_hline(
data=df,
aes(yintercept = ucl),
color = 'black',
linetype = 'dashed',
alpha = 0.25
) +
# lzb line
geom_hline(
data=df,
aes(yintercept = lzb),
color = 'black',
linetype = 'dashed',
alpha = 0.25
) +
# uzb line
geom_hline(
data=df,
aes(yintercept = uzb),
color = 'black',
linetype = 'dashed',
alpha = 0.25
) +
# lzc line
geom_hline(
data=df,
aes(yintercept = lzc),
color = 'black',
linetype = 'dashed',
alpha = 0.25
) +
# uzc line
geom_hline(
data=df,
aes(yintercept = uzc),
color = 'black',
linetype = 'dashed',
alpha = 0.25
) +
# alert limit line if applicable
{if (clre) {
geom_hline(
data = df,
aes(yintercept = alert_lim[1]),
color = 'red',
alpha = 0.5
)
}} +
# blue shading
geom_rect(
data=rects,
aes(xmin = -Inf, xmax = Inf, ymin = ystart, ymax = yend),
alpha = 0.4,
fill = 'lightblue'
) +
ylab('Frequency Count') +
theme(
axis.text.x = element_blank(),
plot.margin = unit(c(0,0,-.25,0), 'cm'),
title = element_text(size = 7)
) +
scale_x_discrete(labels = format_monyr(df$monyr)) +
xlab('') +
ggtitle(paste('Control Chart:', title), subtitle = test)
# layers <- vector('list', length(rl))
# if (any(df$test %in% c(3, 5, 6, 8))) {
# for (i in 1:length(rl)) {
# individuals <- individuals +
# geom_line(
# data = rl[[i]],
# aes(x = monyr, y = complaints, group = 1),
# color = 'red',
# alpha = .25
# )
# }
# individuals <- individuals +
# guides(colour = FALSE)
# } else {
# individuals <- individuals +
# guides(colour = FALSE)
# }
if (clre) {
labels <- data.frame(x = rep(1, 4), y = c(lcl, avg, ucl, df$alert_lim[1]))
} else {
labels <- data.frame(x = rep(1, 3), y = c(lcl, avg, ucl))
}
lplot <- ggplot() +
# LCL label
geom_text(
data = labels,
aes(x=x[1], y = y[1], label = paste('LCL =', y[1])),
hjust = 1,
alpha = .75,
size = 2
) +
# mean label
geom_text(
data = labels,
aes(x=x[2], y = y[2], label = paste('mean =', y[2])),
hjust = .9,
alpha = .75,
size = 2
) +
# UCL label
geom_text(
data = labels,
aes(x=x[3], y = y[3], label = paste('UCL =', y[3])),
hjust = 1,
alpha = .75,
size = 2
) +
# alert limit label
{if (clre) {
geom_text(
data = labels,
aes(x=x[1], y = y[4], label = paste('Alert Limit =', y[4])),
color = 'red',
hjust = .75,
size = 2
) }
} +
scale_y_continuous(
limits = ggplot_build(individuals)$layout$panel_ranges[[1]]$y.range
) +
theme_bw() +
theme(
text = element_text(size = 8),
axis.text = element_blank(),
axis.ticks.y = element_blank(),
line = element_blank(),
panel.border = element_blank(),
plot.margin = unit(c(0,0,-.25,-.5), 'cm')
) +
ggtitle('', subtitle = '') + xlab('') + ylab('')
top <- gridExtra::arrangeGrob(individuals, lplot, ncol = 2, widths = c(5, .875))
rounder <- function(x) {
x <- format(x, digits = 0)
}
moving_range <- ggplot() +
# frequency line
geom_line(
data=df,
aes(x = monyr, y = range, group = 1),
alpha = 0.5
) +
# frequency points
geom_point(
data=df,
aes(x = monyr, y = range, group = 1),
size = 1,
alpha = .5
) +
#frequency labels
geom_text(
data=df,
aes(x = monyr, y = range, label = range),
vjust = 'inward',
size = 2.5
) +
# mean line
geom_hline(
data=df,
aes(yintercept = avgr),
color = 'black',
alpha = 0.75
) +
# lcl line
geom_hline(
data=df,
aes(yintercept = lclr),
color = 'black',
linetype = 'dashed',
alpha = 0.5
) +
# ucl line
geom_hline(
data=df,
aes(yintercept = uclr),
color = 'black',
linetype = 'dashed',
alpha = 0.5
) +
# blue shading
geom_rect(
data=rectsr,
aes(xmin = -Inf, xmax = Inf, ymin = ystart, ymax = yend),
alpha = 0.4,
fill = 'lightblue'
) +
ylab('Moving Range') +
scale_x_discrete(name='month', labels = format_monyr(df$monyr)) +
scale_y_continuous(labels = rounder) +
theme(
plot.margin= unit(c(-.25,0,0,0), 'cm'),
title = element_text(size = 7),
axis.text.x = element_text(size = 5)
) +
ggtitle('')
rlabels <- data.frame(x = rep(1,3), y = c(lclr, avgr, uclr))
rlplot <- ggplot() +
# LCL label
geom_text(
data = rlabels,
aes(x=x[1], y = y[1], label = paste('LCL =', y[1])),
hjust = 1.4,
size = 2
) +
# mean label
geom_text(
data = rlabels,
aes(x=x[2], y = y[2], label = paste('mean =', y[2])),
hjust = 1,
size = 2
) +
# UCL label
geom_text(
data = rlabels,
aes(x=x[3], y = y[3], label = paste('UCL =', y[3])),
hjust = 1,
size = 2
) +
scale_y_continuous(
limits = ggplot_build(moving_range)$layout$panel_ranges[[1]]$y.range
) +
theme_bw() +
theme(
axis.text.y = element_blank(),
axis.text.x = element_text(color = 'white', size = 5),
axis.ticks.y = element_blank(),
line = element_blank(),
panel.border = element_blank(),
plot.margin = unit(c(-.25,0,0,-.5), 'cm'),
title = element_text(size = 7)
) +
ggtitle('') + xlab('') + ylab('')
bottom <- gridExtra::arrangeGrob(moving_range, rlplot, ncol = 2, widths = c(5, .875))
return(gridExtra::arrangeGrob(top, bottom, ncol = 1, heights = c(2, 2)))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.