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

devtools::load_all('~/srms')
knitr::opts_chunk$set(fig.width = 12)

def_cleaner <- function(string) {
  if (grepl('\\\n', string)) {
    return(string)
  }

  string %<>% stringr::str_split(' ', simplify = TRUE) %>% as.character()
  lines <- split(string, ceiling(seq_along(string) / 6))
  lines %<>% lapply(paste, collapse = ' ') %>% as.character() %>% paste(collapse = '\n')

  return(lines)
}

mytheme <- ttheme_default(
  core = list(fg_params=list(cex = .5)),
  colhead = list(fg_params=list(cex = .5)),
  rowhead = list(fg_params=list(cex = .5)))

find_cell <- function(table, row, col, name = 'core-bg') {
  l <- table$layout
  which(l$t==row & l$l==col & l$name==name)
}

grob_binder <- function(ggrob, tgrob) {
  tgrob$heights <- unit.pmax(tgrob$heights)#, unit(2, 'lines'))
  tgrob$widths <- unit(rep(1/ncol(tgrob), ncol(tgrob)), 'npc')

  ggrob %<>% gtable_add_rows(., sum(tgrob$heights))
  ggrob %<>% gtable_add_grob(., grobs = tgrob, t = nrow(ggrob),
                             l = 4, b = nrow(ggrob), r = 4)

  grid.draw(ggrob)
  invisible(ggrob)
}

add_title <- function(grob, title) {
  title <- textGrob(title, gp = gpar(fontsize = 8))
  padding <- unit(5, 'mm')

  grob <- gtable::gtable_add_rows(grob,
                                   heights = grobHeight(title) + padding,
                                   pos = 0)

  grob <- gtable::gtable_add_grob(grob, title, t = 1, l = 1, r = ncol(grob))

  return(grob)
}

make_basic_table <- function(df) {
  DT::datatable(data = df,
            options = list(dom = 'ft',
                           scrollY = '300px',
                           paging = FALSE),
            rownames = FALSE,
            colnames = gsub('\\.|_' ,' ', names(df)),
            escape = FALSE)
}

df <- srms::qs_preprocess(inpath = '~/metrics/Copy of Quality Indicator Metrics 2017 (4).xlsx')

Scorecard

cols <- c('Process.Area', 'Metric', 'Metric.Definition',
          names(df)[grep('Baseline', names(df))],
          names(df)[grep('Target', names(df))],
          names(df)[grep('YTD', names(df))], 'status')

table <- df %>% 
  dplyr::filter(is.na(Type) | Type == 'Total', 
                grepl('Ortho', Function), 
                date == max(date)) %>% 
  dplyr::select(dplyr::one_of(cols)) %>%
  dplyr::mutate(
    Metric = gsub('\\(', '\\\n(', Metric),
    Metric.Definition = purrr::map_chr(Metric.Definition, ~ def_cleaner(.x))
  ) %>%
  setNames(gsub('\\.', ' ', gsub('status', paste(lubridate::year(last_month()), 'YTD Status'), cols)))

col1 <- tableGrob(unique(table['Process Area']), 
                  row = NULL,
                  theme = mytheme)
col2 <- tableGrob(table[-1],
                  row = NULL,
                  theme = mytheme)
halign <- combine(col1, col2, along = 1)

borders <- table %>% 
  dplyr::mutate(row_ind = row_number() + 1) %>%
  dplyr::group_by(`Process Area`) %>%
  dplyr::summarise(top = min(row_ind),
                   bottom = max(row_ind)) %>%
  dplyr::arrange(top)

halign$layout[halign$layout$t != 1 & 
                halign$layout$l == 1, 't'] <- borders$top
halign$layout[halign$layout$b != 1 & 
                halign$layout$l == 1, 'b'] <- borders$bottom

for (i in seq(nrow(table))) {
  ind <- find_cell(table = halign, row = i + 1, col = ncol(table))
  halign$grobs[ind][[1]][['gp']] <- gpar(
    fill = switch(table[, grep('YTD Status', names(table))][i],
                  'On Target' = '#00ff00',
                  'At Risk to Miss Target' = '#ffff00',
                  'Off Target' = '#ff0000',
                  'NA' = 'grey')
  )
}

grid.draw(halign)

Field Actions {data-navmenu='Metric'}

raw <- df %>% dplyr::filter(Metric == 'Field Actions')
cols <- c('Function', names(df)[grep('Baseline', names(df))],
          names(df)[grep('Target', names(df))],
          names(df)[grep('YTD', names(df))], 'date', 'display.value')
table <- raw %>%
  dplyr::select(dplyr::one_of(cols)) %>%
  dplyr::mutate(date = strftime(date, format = '%b\n%Y'),
                Function = gsub('-', '\n', gsub(' /', ' /\n', gsub(' \\(', '\n(', Function)))) %>%
  tidyr::spread(date, display.value) %>%
  setNames(gsub(' \\(', '\n(', names(.))) %>%
  tableGrob(row = NULL, theme = mytheme)

bullet <- ggplotGrob(
  ggplot(raw, 
         aes(x = Metric, y = value, 
             fill = strftime(date, format= '%m-%b'))) + 
    geom_col(color = 'black') + 
    geom_hline(yintercept = as.numeric(
      unique(raw[, names(df)[grep('Baseline', names(df))]])
    )) +
    geom_text(aes(x = Metric, y = as.numeric(
      unique(raw[, names(df)[grep('Baseline', names(df))]])
    ), label = 'Baseline'), vjust = 1, angle = 90, size = 3) +
    theme(legend.position = 'top',
          axis.title = element_blank(),
          legend.text = element_text(size = 7)) +
    guides(fill = guide_legend(title = 'Month')) +
    coord_flip()
)

line <- ggplotGrob(
  ggplot(raw, 
         aes(x = date, y = value)) +
    geom_point() +
    geom_line(group = 1) +
    geom_text_repel(aes(label = value), size = 3) +
    scale_x_datetime(date_breaks = '1 month', date_labels = '%b-%Y') +
    theme(axis.title = element_blank()) +
    ggtitle('Field Actions per Month')
)

grob_binder(ggrob = rbind(line, bullet), tgrob = table)

Avg. # Audit Observations / Inspection {data-navmenu='Metric'}

raw <- df %>% dplyr::filter(Metric == 'Avg. # Audit Observation / Inspection')

table <- raw %>%
  dplyr::select(dplyr::one_of(cols)) %>%
  dplyr::mutate(date = strftime(date, format = '%b\n%Y'),
                Function = gsub('-', '\n', gsub(' /', ' /\n', gsub(' \\(', '\n(', Function)))) %>%
  tidyr::spread(date, display.value) %>%
  setNames(gsub(' \\(', '\n(', names(.))) %>%
  tableGrob(row = NULL, theme = mytheme)

line <- ggplotGrob(
  ggplot(raw,
         aes(x = date, y = value)) +
    geom_point() +
    geom_line(group = 1) +
    geom_text_repel(aes(label = display.value), size = 3) +
    scale_x_datetime(date_breaks = '1 month', date_labels = '%b-%Y') +
    geom_hline(yintercept = as.numeric(
      unique(raw[, names(df)[grep('Baseline', names(df))]])
    )) +
    geom_text(aes(x = min(date), y = as.numeric(
      unique(raw[, names(df)[grep('Baseline', names(df))]])
    ), label = 'Baseline'), vjust = -1, size = 3) +
    theme(axis.title = element_blank()) +
    ggtitle('Avg.# Audit Observation / Inspection Over Time')
)

grob_binder(ggrob = line, tgrob = table)

Overdue CAPA {data-navmenu='Metric'}

Column {.tabset .tabset-fade}

raw <- df %>% dplyr::filter(Metric == 'Overdue CAPA')

bullet <- ggplotGrob(
  ggplot(raw %>% 
           dplyr::filter(Function == 'Ortho (as a whole)',
                         date == max(date)),
         aes_string(
           x = 'Metric', 
           y = paste0('as.numeric(', '`', 
                      names(raw)[grep('YTD', names(raw))], 
                      '`', ')')
         )
  ) +
    geom_col(fill = 'white', color = 'black') +
    geom_text(
      aes_string(
        label = paste0('`', names(raw)[grep('YTD', names(raw))], '`')
      ),
      hjust = 'outward', size = 3) +
    geom_hline(yintercept = as.numeric(
      unique(raw[, grep('Target', names(raw))])
    )) +
    geom_text(aes(x = Metric, y = as.numeric(
      unique(get(names(raw)[grep('Target', names(raw))]))
    ), label = 'Target'), vjust = 1, angle = 90, size = 3) +
    coord_flip() +
    theme(axis.title = element_blank())
)

bar_df <- raw %>% 
  dplyr::filter(date == max(date),
                Function != 'Ortho (as a whole)') %>%
  dplyr::mutate(
    ytd = as.numeric(.[[grep('YTD', names(raw))]])
  ) %>%
  dplyr::filter(ytd != 0) %>%
  dplyr::arrange(ytd) %>%
  dplyr::mutate(
    percent = ytd / sum(ytd),
    perc = paste0(round(100 * percent, 1), '%'),
    Function = factor(Function, levels = Function[order(-ytd)], ordered = TRUE),
    vj = rep(c(1, 0, -1), length.out = nrow(.))
  )
bar <- ggplotGrob(
  ggplot(bar_df,
         aes(x = Metric, y = percent, 
             fill = Function)) +
    geom_col(width = 1, color = 'black') +
    geom_text(aes(label = perc, vjust = vj),
              position = position_stack(vjust = .5),
              size = 3) +
    theme(legend.position = 'top',
          legend.text = element_text(size = 7),
          axis.title = element_text(size = 7)) +
    labs(y = 'Percent of Total', x = '') +
    coord_flip()
)

Overdue CAPA Counts

tab1 <- raw %>% 
  dplyr::select(dplyr::one_of(cols)) %>%
  dplyr::mutate(date = strftime(date, format = '%b\n%Y'),
                Function = gsub('-', '\n', gsub(' /', ' /\n', gsub(' \\(', '\n(', Function)))) %>%
  tidyr::spread(date, display.value) %>%
  dplyr::arrange_(.dots = paste0('-as.numeric(`', names(raw)[grep('YTD', names(raw))], '`)')) %>%
  setNames(gsub(' \\(', '\n(', names(.))) %>%
  tableGrob(row = NULL, theme = mytheme) %>%
  add_title(grob = ., title = 'Counts of Overdue CAPA')

grob_binder(ggrob = bullet, tgrob = tab1)

Overdue CAPA Proportions Chart

tab2 <- raw %>%
  dplyr::select(dplyr::one_of(cols), value) %>%
  dplyr::mutate(date = strftime(date, format = '%b\n%Y'),
                Function = gsub('-', '\n', gsub(' /', ' /\n', gsub(' \\(', '\n(', Function)))) %>%
  dplyr::group_by(date) %>%
  tidyr::nest() %>%
  dplyr::mutate(
    data = purrr::map(
      .x = data,
      .f = ~ .x %>% 
        dplyr::arrange(value) %>%
        dplyr::mutate(percent = paste0(round(100 * value / max(value), 1), '%'))
    )
  ) %>%
  tidyr::unnest(data) %>%
  dplyr::select(dplyr::one_of(cols), percent) %>%
  dplyr::select(-display.value) %>% 
  tidyr::spread(date, percent, fill = '0%') %>%
  dplyr::arrange_(.dots = paste0('-as.numeric(`', names(raw)[grep('YTD', names(raw))], '`)')) %>%
  setNames(gsub(' \\(', '\n(', names(.))) %>%
  tableGrob(row = NULL, theme = mytheme) %>%
  add_title(grob = ., title = 'Percent of Overdue CAPA by Month by Function')

grid.draw(bar)

Overdue CAPA Proportions Table

grid.draw(tab2)

Aged CAPA {data-navmenu='Metric'}

Column {.tabset .tabset-fade}

raw <- df %>% dplyr::filter(Metric == 'Aged CAPA')

bullet <- ggplotGrob(
  ggplot(raw %>% 
           dplyr::filter(Function == 'Ortho (as a whole)',
                         date == max(date)),
         aes_string(
           x = 'Metric', 
           y = paste0('as.numeric(', '`', 
                      names(raw)[grep('YTD', names(raw))], 
                      '`', ')')
         )
  ) +
    geom_col(fill = 'white', color = 'black') +
    geom_text(
      aes_string(
        label = paste0('`', names(raw)[grep('YTD', names(raw))], '`')
      ),
      hjust = 'outward', size = 3) +
    geom_hline(yintercept = as.numeric(
      unique(raw[, grep('Target', names(raw))])
    )) +
    geom_text(aes(x = Metric, y = as.numeric(
      unique(get(names(raw)[grep('Target', names(raw))]))
    ), label = 'Target'), vjust = 1, angle = 90, size = 3) +
    coord_flip() +
    theme(axis.title = element_blank())
)

bar_df <- raw %>% 
  dplyr::filter(date == max(date),
                Function != 'Ortho (as a whole)') %>%
  dplyr::mutate(
    ytd = as.numeric(.[[grep('YTD', names(raw))]])
  ) %>%
  dplyr::filter(ytd != 0) %>%
  dplyr::arrange(ytd) %>%
  dplyr::mutate(
    percent = ytd / sum(ytd),
    perc = paste0(round(100 * percent, 1), '%'),
    Function = factor(Function, levels = Function[order(-ytd)], ordered = TRUE),
    vj = rep(c(1, 0, -1), length.out = nrow(.))
  )
bar <- ggplotGrob(
  ggplot(bar_df,
         aes(x = Metric, y = percent, 
             fill = Function)) +
    geom_col(width = 1, color = 'black') +
    geom_text(aes(label = perc, vjust = vj),
              position = position_stack(vjust = .5),
              size = 3) +
    theme(legend.position = 'top',
          legend.text = element_text(size = 7),
          axis.title = element_text(size = 7)) +
    labs(y = 'Percent of Total', x = '') +
    coord_flip()

)

Aged CAPA Counts

tab1 <- raw %>% 
  dplyr::select(dplyr::one_of(cols)) %>%
  dplyr::mutate(date = strftime(date, format = '%b\n%Y'),
                Function = gsub('-', '\n', gsub(' /', ' /\n', gsub(' \\(', '\n(', Function)))) %>%
  tidyr::spread(date, display.value) %>%
  dplyr::arrange_(.dots = paste0('-as.numeric(`', names(raw)[grep('YTD', names(raw))], '`)')) %>%
  setNames(gsub(' \\(', '\n(', names(.))) %>%
  tableGrob(row = NULL, theme = mytheme) %>%
  add_title(grob = ., title = 'Counts of Aged CAPA')

grob_binder(ggrob = bullet, tgrob = tab1)

Aged CAPA Proportions Chart

tab2 <- raw %>%
  dplyr::select(dplyr::one_of(cols), value) %>%
  dplyr::mutate(date = strftime(date, format = '%b\n%Y'),
                Function = gsub('-', '\n', gsub(' /', ' /\n', gsub(' \\(', '\n(', Function)))) %>%
  dplyr::group_by(date) %>%
  tidyr::nest() %>%
  dplyr::mutate(
    data = purrr::map(
      .x = data,
      .f = ~ .x %>% 
        dplyr::arrange(value) %>%
        dplyr::mutate(percent = paste0(round(100 * value / max(value), 1), '%'))
    )
  ) %>%
  tidyr::unnest(data) %>%
  dplyr::select(dplyr::one_of(cols), percent) %>%
  dplyr::select(-display.value) %>% 
  tidyr::spread(date, percent, fill = '0%') %>%
  dplyr::arrange_(.dots = paste0('-as.numeric(`', names(raw)[grep('YTD', names(raw))], '`)')) %>%
  setNames(gsub(' \\(', '\n(', names(.))) %>%
  tableGrob(row = NULL, theme = mytheme) %>%
  add_title(grob = ., title = 'Percent of Aged CAPA by Month by Function')

grid.draw(bar)

Aged CAPA Proportions Table

grid.draw(tab2)

Overdue COs {data-navmenu='Metric'}

Column {.tabset .tabset-fade}

raw <- df %>% dplyr::filter(Metric == 'Overdue COs')

bullet_total <- ggplotGrob(
  ggplot(raw %>% 
           dplyr::filter(Function == 'Ortho (as a whole)',
                         date == max(date),
                         Type == 'Total'),
         aes_string(
           x = 'Metric', 
           y = paste0('as.numeric(', '`', 
                      names(raw)[grep('YTD', names(raw))], 
                      '`', ')')
         )
  ) +
    geom_col(fill = 'white', color = 'black') +
    geom_text(
      aes_string(
        label = paste0('`', names(raw)[grep('YTD', names(raw))], '`')
      ),
      hjust = 'outward', size = 3) +
    geom_hline(yintercept = as.numeric(
      unique(raw[, grep('Target', names(raw))])
    )) +
    geom_text(aes(x = Metric, y = as.numeric(
      unique(get(names(raw)[grep('Target', names(raw))]))
    ), label = 'Target'), vjust = 1, angle = 90, size = 3) +
    coord_flip() +
    theme(axis.title = element_blank())
)

line <- ggplotGrob(
  ggplot(raw %>%
           dplyr::mutate(Type = factor(Type, levels = c('Total', 'Open', 'Closed'))),
         aes(x = date, y = value, 
             color = Function, group = Function)) +
    geom_point() +
    geom_line() +
    geom_text_repel(aes(label = display.value), size = 3) +
    scale_x_datetime(date_breaks = '1 months', date_labels = '%b-%Y') +
    facet_grid(Type ~ ., scales = 'free_y') +
    ylab('Overdue COs') +
    theme(legend.position = 'top',
          legend.text = element_text(size = 7),
          legend.title = element_text(size = 7),
          axis.title.x = element_blank(),
          axis.title.y = element_text(size = 7),
          axis.text = element_text(size = 7)) +
    scale_color_tableau()
)

bar <- ggplotGrob(
  ggplot(raw %>% 
           dplyr::filter(Function == 'Ortho (as a whole)'), 
         aes(x = date, y = value, group = Type)) + 
    geom_col(aes(fill = Type), position = 'dodge', color = 'black') +
    scale_fill_tableau() + 
    ylab('Overdue COs') +
    scale_x_datetime(date_breaks = '1 month', date_labels = '%b-%Y') +
    theme(axis.title.x = element_blank(),
          axis.title.y = element_text(size = 7),
          axis.text = element_text(size = 7),
          legend.position = 'top',
          legend.title = element_text(size = 7),
          legend.text = element_text(size = 7))
)

table <- raw %>%
  dplyr::select(dplyr::one_of(cols), Type) %>%
  dplyr::mutate(date = strftime(date, format = '%b\n%Y'),
                Function = gsub('-', '\n', gsub(' /', ' /\n', gsub(' \\(', '\n(', Function)))) %>%
  tidyr::spread(date, display.value) %>%
  dplyr::mutate(Type = factor(Type, levels = c('Total', 'Open', 'Closed'))) %>%
  dplyr::arrange(Function, Type) %>%
  setNames(gsub(' \\(', '\n(', names(.)))

col1 <- tableGrob(unique(table['Function']), 
                  row = NULL,
                  theme = mytheme)
col2 <- tableGrob(table[-1],
                  row = NULL,
                  theme = mytheme)
halign <- combine(col1, col2, along = 1)

borders <- table %>% 
  dplyr::mutate(row_ind = row_number() + 1) %>%
  dplyr::group_by(Function) %>%
  dplyr::summarise(top = min(row_ind),
                   bottom = max(row_ind)) %>%
  dplyr::arrange(top)

halign$layout[halign$layout$t != 1 & 
                halign$layout$l == 1, 't'] <- borders$top
halign$layout[halign$layout$b != 1 & 
                halign$layout$l == 1, 'b'] <- borders$bottom

Overdue COs Summary

grob_binder(ggrob = bullet_total, tgrob = halign)

Overdue COs Chart

grid.draw(bar)

Total Number of NCs Created (non-supplier and supplier NCs) {data-navmenu='Metric'}

raw <- df %>% dplyr::filter(Metric == 'Total number of NCs created(non-supplier and supplier NCs)')

table <- raw %>%
  dplyr::select(dplyr::one_of(cols), display.value) %>%
  dplyr::mutate(date = strftime(date, format = '%b\n%Y')) %>%
  tidyr::spread(date, display.value) %>%
  setNames(gsub(' \\(', '\n(', names(.))) %>%
  tableGrob(row = NULL, theme = mytheme)

line <- ggplotGrob(
  ggplot(raw,
         aes(x = date, y = value)) +
    geom_point() +
    geom_line(group = 1) +
    geom_text_repel(aes(label = display.value), size = 3) +
    scale_x_datetime(date_breaks = '1 month', date_labels = '%b-%Y') +
    ylab('NCs Created') +
    theme(axis.text = element_text(size = 7),
          axis.title.y = element_text(size = 7),
          axis.title.x = element_blank())
)

grob_binder(ggrob = line, tgrob = table)

Metric Methodologies

df %>% 
  dplyr::select(Process.Area, Metric, Methodology) %>%
  unique() %>%
  dplyr::mutate(Methodology = gsub('YTD', '<br>YTD', Methodology)) %>%
  make_basic_table()

r knitr::knit(text = knitr::knit_expand(system.file('rmd/qs_methodology.Rmd', package = 'srms')))

kimjam/srms documentation built on May 20, 2019, 10:21 p.m.