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

scorecard_parse <- function(df, filter) {
  df %<>%
    dplyr::filter_(filter) %>% 
    dplyr::filter(date == max(date)) %>% 
    dplyr::select(Process.Area, Metric, Function, 
                  `Baseline.(2016)`, Current.Month, 
                  `YTD.(2017)`, `6.Month.Trend`) %>%
    dplyr::mutate(
      Metric = dplyr::case_when(
        grepl('%First', .$Metric) ~ gsub('\\(', '\\\n(', .$Metric), 
        TRUE ~ .$Metric),
      Process.Area = dplyr::case_when(
        .$Process.Area == 'Supplier Response Timeliness' ~ 
          'Supplier Response \nTimeliness',
        .$Process.Area == 'Quality Records Management' ~
          'Quality Records \nManagement',
        TRUE ~ .$Process.Area),
      `6.Month.Trend` = dplyr::case_when(
        .$`6.Month.Trend` == '1' ~ 'Favorable Trend',
        .$`6.Month.Trend` == '0' ~ 'No Significant Trend',
        .$`6.Month.Trend` == '-1' ~ 'Unfavorable Trend',
        is.na(.$`6.Month.Trend`) ~ 'NA',
        TRUE ~ .$`6.Month.Trend`)
    )
}

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

scorecard_vis <- function(df) {
  df %<>% dplyr::filter(`6.Month.Trend` != 'NA')

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

  names(df) <- gsub('\\.', ' ', names(df))

  col1 <- tableGrob(unique(df['Process Area']), 
                    row = NULL,
                    theme = mytheme)
  col2 <- tableGrob(unique(df['Metric']), 
                    row = NULL,
                    theme = mytheme)
  col3 <- tableGrob(df[-(1:2)], 
                    row = NULL,
                    theme = mytheme)

  halign <- gridExtra::combine(col1, col2, col3, along = 1)

  borders <- df %>% 
    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

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

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

  for (i in seq(nrow(df))) {
    ind <- find_cell(table = halign, row = i + 1, col = ncol(df))
    halign$grobs[ind][[1]][['gp']] <- gpar(
      fill = switch(df$`6 Month Trend`[i],
                    'Unfavorable Trend' = '#ff0000',
                    'No Significant Trend' = '#ffff00',
                    'Favorable Trend' = '#00ff00'))
  }

  footnote <- textGrob('*Calculated as monthly average',
                       hjust = 0,
                       gp = gpar(fontsize = 7))
  padding <- unit(0.5, 'line')
  halign <- gtable_add_rows(halign,
                        heights = grobHeight(footnote) + padding)
  halign <- gtable_add_grob(halign, grobs = footnote, t = nrow(halign), l = 4, r = ncol(halign))

  return(halign)
}

site_data <- function(df, site) {
  dflist <- vector('list', 3)
  names(dflist) <- c('long', 'wide', 'trends')

  tables_long <- df %>%
    dplyr::filter(
      Site.Source == site,
      dplyr::between(date, 
                     lubridate::floor_date(Sys.time(), 'month') - months(14), 
                     lubridate::floor_date(Sys.time(), 'month') - months(1))
    ) %>% 
    dplyr::select(Site.Source, Function, Metric, Metric.Type,
                  date, value, Display.Value, slope, pval) %>% 
    dplyr::select(-Metric.Type) %>% 
    split(., .$Metric)

  dflist$long <- tables_long

  if (site == 'Ortho') {
    tables_long <- df %>%
      dplyr::filter(
        dplyr::between(date,
                       lubridate::floor_date(Sys.time(), 'month') - months(14),
                       lubridate::floor_date(Sys.time(), 'month') - months(1))
      ) %>%
      dplyr::select(Site.Source, Function, Metric, Metric.Type,
                    date, value, Display.Value, slope, pval) %>%
      dplyr::select(-Metric.Type) %>%
      split(., .$Metric)
  }

  tables_wide <- lapply(
    tables_long,
    function(x)
      tidyr::spread(data = x %>% 
                      dplyr::filter(!Site.Source %in% c('External Manufacturing',
                                                        'Distribution Quality',
                                                        'Other')) %>%
                      dplyr::select(-Metric, -slope, -pval, -value) %>% 
                      dplyr::mutate(
                        Site.Source = factor(Site.Source,
                                             levels = c('Ortho', 'Pencoed', 
                                                        'Pompano Beach', 'Raritan', 
                                                        'Rochester', 'Nypro Baja', 'Strasbourg',
                                                        'Other', 
                                                        'Distribution Quality', 
                                                        'External Manufacturing'))) %>% 
                      dplyr::filter(!is.na(Site.Source)) %>%
                      dplyr::arrange(Site.Source), 
                    key = date, 
                    value = Display.Value)
  )

  names(tables_wide[[1]])[3:ncol(tables_wide[[1]])] %<>% 
    gsub(pattern = ' GMT', 
         replacement = '', 
         x = strftime(as.POSIXct(.), 
                      format = '%b %Y', 
                      tz = 'GMT'))

  colnames <- names(tables_wide[[1]])

  tables_wide %<>% lapply(., setNames, colnames)

  dflist$wide <- tables_wide

  dflist$trends <- lapply(
    tables_long,
    function(x)
      x %>% 
      dplyr::filter(Site.Source == site) %>% 
      dplyr::select(Function, slope, pval) %>% 
      dplyr::mutate(slope = round(slope, 3),
                    pval = round(pval, 3)) %>% 
      unique() %>%
      dplyr::arrange(Function)
  )

  return(dflist)
}

metric_chart <- function(df) {
  p <- ggplot(data = df %>% 
                dplyr::mutate(
                  Used.For.Trending = ifelse(
                    date >= lubridate::floor_date(Sys.time(), 'month') - months(7), 
                    'Yes', 
                    'No'),
                  date = as.Date(date)
                ),
              aes(x = date, y = value)) +
    geom_point(aes(color = Used.For.Trending)) +
    geom_text(aes(label = Display.Value, hjust = 'inward', vjust = 'inward'), size = 3) +
    geom_line(alpha = .6) +
    geom_line(aes(color = Used.For.Trending),
              alpha = .75) +
    geom_smooth(se = FALSE, method = 'lm', 
                aes(color = Used.For.Trending),
                alpha = .75,
                linetype = 2) +
    scale_x_date(date_breaks = '1 month', date_labels = '%b %Y') +
    theme(axis.title.x = element_blank(),
          axis.title.y = element_blank(),
          legend.position = 'top',
          legend.text = element_text(size = 8),
          text = element_text(size = 8)) +
    labs(title = paste(unique(df$Metric)),
         color = 'Used for Trending') +
    facet_grid(Function ~ ., scales = 'free') +
    scale_color_tableau()

  p
}

basic_table <- function(df) {
  DT::datatable(data = df,
                options = list(dom = 't',
                               pageLength = 20,
                               columnDefs = list(list(className = 'dt-center',
                                                      targets = 1))),
                rownames = FALSE,
                colnames = gsub('\\.' ,' ', names(df)),
                escape = TRUE)
}

get_row_fg <- function(df, index) {
  cols <- matrix(NA, nrow = nrow(df), ncol = ncol(df))
  cols[, 1:(index - 1)] <- 'black'
  cols[, index:8] <- '#1f77b4'
  cols[, 9:ncol(df)] <- '#ff7f0e'

  return(cols)
}

grob_arranger <- function(metric, tablist) {
  g1 <- ggplotGrob(
    metric_chart(df = tablist$long[[metric]])
  )

  g2 <- tableGrob(
    tablist$trends[[metric]],
    rows = NULL,
    theme = ttheme_default(
      core = list(fg_params=list(cex = .7)),
      colhead = list(fg_params=list(cex = .7)),
      rowhead = list(fg_params=list(cex = .7))
    )
  )

  g2$heights <- unit(rep(1/(nrow(g2)), nrow(g2)), 'npc')
  g2$widths <- unit.pmax(g2$widths, unit(2, 'lines'))

  g1 <- gtable_add_cols(g1, sum(g2$widths))
  g1 <- gtable_add_grob(g1, grobs = g2, t = 1, l = ncol(g1), 
                        b = 5, r = ncol(g1))

  tablist$wide[[metric]]$Site.Source %<>% gsub(' ', '\\\n', .)
  tablist$wide[[metric]]$Function %<>% gsub(' | - ', '\\\n', .)

  names(tablist$wide[[metric]]) %<>% gsub('\\.| ', '\\\n', .)
  names(tablist$wide[[metric]])[1] <- 'Site Source'

  col1 <- tableGrob(unique(tablist$wide[[metric]][1]),
                    row = NULL,
                    theme = ttheme_default(
                      core = list(fg_params=list(cex = .65)),
                      colhead = list(fg_params=list(cex = .65)),
                      rowhead = list(fg_params=list(cex = .65))
                    ))

  col2 <- tableGrob(tablist$wide[[metric]][-1],
                    row = NULL,
                    theme = ttheme_default(
                      core = list(fg_params=list(cex = .65,
                                                 col = get_row_fg(
                                                   tablist$wide[[metric]], 
                                                   index = 2))
                      ),
                      colhead = list(fg_params=list(cex = .65)),
                      rowhead = list(fg_params=list(cex = .65))
                    ))

  g3 <- gridExtra::combine(col1, col2, along = 1)

  borders <- tablist$wide[[metric]] %>%
    dplyr::mutate(row_ind = row_number() + 1) %>%
    dplyr::group_by(`Site Source`) %>%
    dplyr::summarise(top = min(row_ind),
                     bottom = max(row_ind)) %>%
    dplyr::arrange(top)

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

  g3$heights <- unit.pmax(g3$heights, unit(2, 'lines'))
  g3$widths <- unit(rep(1/(ncol(g3)), ncol(g3)), 'npc')


  if (any(grepl('\\*', tablist$long[[metric]]$Display.Value))) {
    footnote <- textGrob('*Includes Nypro Operate in Place Data',
                         hjust = 0,
                         gp = gpar(fontsize = 8))
    padding <- unit(0.5, 'line')
    g3 <- gtable_add_rows(g3,
                          heights = grobHeight(footnote) + padding)
    g3 <- gtable_add_grob(g3, grobs = footnote, t = nrow(g3), l = 10, r = ncol(g3))
  }

  g1 <- gtable_add_rows(g1, sum(g3$heights))
  g1 <- gtable_add_grob(g1, grobs = g3, t = nrow(g1), 
                        l = 4, b = nrow(g1), r = ncol(g1))

  grid.draw(g1)
  invisible(g1)
}

metdeft <- function(site) {
  defs <- df %>% 
    dplyr::filter(Site.Source == site) %>% 
    dplyr::select(Process.Area, Metric, 
                  Customer.Rationale, 
                  Metric.Definition) %>% 
    unique() %>%
    dplyr::mutate(Customer.Rationale = stringr::str_wrap(Customer.Rationale, 60),
                  Metric.Definition = stringr::str_wrap(Metric.Definition, 60))

  return(defs)
}

df <- srms::qo_preprocess(write = FALSE)
names(df) <- gsub(' ', '\\.', names(df))

date <- strftime(
  lubridate::floor_date(Sys.time(), 'month') - lubridate::ddays(1),
  format = '%m-%Y'
)

sites <- c('Ortho', 'Rochester', 'Raritan', 'Pencoed', 'Pompano Beach')

out <- NULL
for (site in sites) {
  tables <- site_data(df = df, site = site)
  table <- scorecard_parse(df = df,
                           filter = paste0('Site.Source == \'', site, '\'')) %>%
    dplyr::filter(!is.na(`6.Month.Trend`))
  metrics = gsub('\\\n', '', table$Metric %>% .[!duplicated(.)])
  out <- c(
    out,
    knitr::knit_expand(
      text = paste0(
        '\n{{site}} {.storyboard data-navmenu=\'Site\'}',
        '\n=========================================',
        '\n### {{site}} Quality Operations Scorecard',
        '\n```r}-sc, fig.width = 12}',
        '\ntables <- site_data(df = df, site = \'{{site}}\')',
        '\ntable <- scorecard_parse(df = df, filter = \'Site.Source == \"{{site}}\"\') %>%',
        '\ndplyr::filter(!is.na(`6.Month.Trend`))',
        '\nmetrics = gsub(\'\\\\\\n\', \'\', table$Metric %>% .[!duplicated(.)])',
        '\ngrid.draw(scorecard_vis(table))',
        '\n```'
      ),
      site = site
    )
  )
  for (metric in metrics) {
    out <- c(
      out,
      knitr::knit_expand(
        text = paste0(
          '\n### {{site}} - {{metric}}',
          '\n```r}-{{abbrev}}, fig.height = 8, fig.width = 10}',
          '\ngrob_arranger(metric = \'{{metric}}\', tablist = tables)',
          '\n```'
        ),
        abbrev =  gsub(' ', '', gsub('#|\\(|\\)|%', '', metric)),
        metric = metric,
        site = site
      )
    )
  }
}

r knitr::knit(text = out)

Metric Definitions

basic_table(df = metdeft(site = 'Ortho'))

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

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