R/ggcc.R

In kimjam/srms: Package to automate tasks and reporting for OCD SRMS Team.

#' @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)))
}