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

knitr::opts_chunk$set(fig.width = 12)

get_ib <- function() {
  ib <- openxlsx::read.xlsx('~/raw_data/olap_ib_refurb.xlsx', startRow = 4) %>%
    setNames(c('region', 'Family_Code', 'yyyymm', 'refurb_ind', 'installbase'))

  ib[1:4] %<>% lapply(zoo::na.locf)

  ib %<>%
    dplyr::mutate(
      Family_Code = dplyr::case_when(
        .$Family_Code == '350' ~ '250',
        .$Family_Code == 'IMMUNO SYS'  ~ '3600',
        .$Family_Code == 'INTEGRATED SYS' ~ '5600',
        .$Family_Code == 'ECQ' ~ 'ECI',
        .$Family_Code %in% c('LABAUT', 'INSTMGR') ~ 'enGen',
        .$Family_Code %in% c('AUTOVUE I', 'AUTOVUE U') ~ 'AUTOVUE IU',
        .$Family_Code %in% c('VISION BV', 'VISION MAX BV') ~ 'VISION BV / MAX BV',
        .$Family_Code %in% c('VISION MTS', 'VISION MAX MTS') ~ 'VISION MTS / MAX MTS',
        TRUE ~ .$Family_Code
      )
    ) %>%
    dplyr::filter(Family_Code %in% c('250', 'FS', 'ECI', '5600', '3600')) %>%
    dplyr::group_by(Family_Code, refurb_ind, yyyymm) %>%
    dplyr::summarise(installbase = sum(installbase)) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(refurb_ind = dplyr::case_when(
      .$refurb_ind == 'Y' ~ 'Refurbished',
      .$refurb_ind == 'N' ~ 'Regular',
      TRUE ~ .$refurb_ind
    ))

  return(ib)
}

get_row_bg <- function(df) {
  mask <- vapply(df, is.numeric, logical(1))
  cols <- t(scale(t(as.matrix(df[mask])))) %>%
    apply(.,
          1,
          function(x)
            dplyr::case_when(
              x < -2 ~ '#198c19',
              dplyr::between(x, -2, -1.5) ~ '#4ca64c',
              dplyr::between(x, -1.5, -1) ~ '#7fbf7f',
              dplyr::between(x, -1, -.5) ~ '#b2d8b2',
              dplyr::between(x, -.5, 0) ~ '#e5f2e5',
              dplyr::between(x, 0, .5) ~ '#ffe5e5',
              dplyr::between(x, .5, 1) ~ '#ffb2b2',
              dplyr::between(x, 1, 1.5) ~ '#ff7f7f',
              dplyr::between(x, 1.5, 2) ~ '#ff4c4c',
              x > 2 ~ '#ff1919',
              TRUE ~ 'black'
            )) %>%
    t() %>%
    cbind(matrix(rep('grey', sum(!mask) * nrow(.)), ncol = sum(!mask)), .)

  return(cols)
}

make_row_heat_tgrob <- function(df, flex = FALSE) {
  cex <- ifelse(flex, .5, 1)
  return(df %<>%
           tableGrob(
             row = NULL,
             theme = ttheme_default(
               core = list(fg_params = list(cex = cex),
                           bg_params = list(fill = get_row_bg(.))),
               colhead = list(fg_params = list(cex = cex)),
               rowhead = list(fg_params = list(cex = cex)))
           ))
}

grid_arrange_shared_legend <- function(..., ncol = length(list(...)), nrow = 1, position = c("bottom", "right")) {

  plots <- list(...)
  position <- match.arg(position)
  g <- ggplotGrob(plots[[1]] + theme(legend.position = position))$grobs
  legend <- g[[which(sapply(g, function(x) x$name) == "guide-box")]]
  lheight <- sum(legend$height)
  lwidth <- sum(legend$width)
  gl <- lapply(plots, function(x) x + theme(legend.position="none"))
  gl <- c(gl, ncol = ncol, nrow = nrow)

  combined <- switch(position,
                     "bottom" = arrangeGrob(do.call(arrangeGrob, gl),
                                            legend,
                                            ncol = 1,
                                            heights = unit.c(unit(1, "npc") - lheight, lheight)),
                     "right" = arrangeGrob(do.call(arrangeGrob, gl),
                                           legend,
                                           ncol = 2,
                                           widths = unit.c(unit(1, "npc") - lwidth, lwidth)))


  return(combined)
}

add_title <- function(tgrob, title, flex = FALSE) {
  fontsize <- ifelse(flex, 8, 12)
  title <- textGrob(title, gp = gpar(fontsize = fontsize))

  padding <- unit(5, 'mm')

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

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

  return(tgrob)
}

cl_viz <- function(x) {
  count <- x %>% 
    dplyr::group_by(Refurbished, YYYYMM) %>% 
    dplyr::summarise(complaints = n())

  norm <- x %>%
    dplyr::group_by(Refurbished, YYYYMM, Family_Code) %>% 
    dplyr::summarise(complaints = n()) %>%
    dplyr::ungroup() %>%
    dplyr::left_join(y = ib,
                     by = c('Family_Code', 'YYYYMM' = 'yyyymm', 'Refurbished' = 'refurb_ind')) %>%
    dplyr::mutate(complaint_rate = round(100 * complaints / installbase, 1)) %>%
    dplyr::select(Refurbished, YYYYMM, complaint_rate)

  count_tab <- count %>%
    tidyr::spread(YYYYMM, complaints, fill = 0) %>% 
    make_row_heat_tgrob() %>%
    add_title(title = 'Complaint Count Table')

  normalized_tab <- norm %>%
    tidyr::spread(YYYYMM, complaint_rate, fill = 0) %>%
    make_row_heat_tgrob() %>%
    add_title(title = 'Complaints per 100 Analyzers Table')

  count_chart <- ggplot(count, aes(x = YYYYMM, y = complaints,
                                   fill = Refurbished)) + 
    geom_col(color = 'black') +
    scale_fill_tableau() +
    labs(title = 'Complaint Count by Month',
         y = 'Complaints') +
    theme(axis.title.x = element_blank(),
          axis.title.y = element_text(size = 7),
          legend.position = 'top')

  norm_chart <- ggplot(norm, aes(x = YYYYMM, y = complaint_rate,
                                 group = Refurbished, color = Refurbished)) +
    geom_point() + geom_line(alpha = .5) +
    geom_text_repel(aes(label = complaint_rate), size = 3) +
    scale_color_tableau() +
    labs(title = 'Complaints per 100 Analyzers by Month',
         y = 'Complaints per 100 Analyzers') +
    theme(axis.title.x = element_blank(),
          axis.title.y = element_text(size = 7),
          legend.position = 'top')

  chart <- grid_arrange_shared_legend(count_chart, norm_chart, ncol = 1, 
                                      nrow = 2, position = 'bottom')

  return(list('count_tab' = count_tab,
              'normalized' = normalized_tab,
              'chart' = chart))
}

raw_df <- srms::roc_eq_v26b() %>%
  dplyr::filter(Family_Code %in% c('250', 'FS', 'ECI', '5600', '3600'),
                Product_Number_T545CC != 3357) %>%
  dplyr::mutate(
    YYYYMM = as.character(YYYYMM),
    Refurbished = dplyr::case_when(
      .$Family_Code == '250' & .$Product_Number_T545CC == 3334 ~ 'Refurbished',
      .$Family_Code == 'FS' & .$Product_Number_T545CC == 3402 ~ 'Refurbished',
      .$Family_Code == 'ECI' & .$Product_Number_T545CC == 3358 ~ 'Refurbished',
      .$Family_Code == '5600' & .$Product_Number_T545CC == 5602 ~ 'Refurbished',
      .$Family_Code == '3600' & .$Product_Number_T545CC %in% c(36000267, 36000409, 36000674) ~ 'Refurbished',
      TRUE ~ 'Regular'
    )
  )

ib <- get_ib()

viz_list <- raw_df %>%
  split(.$Family_Code) %>%
  lapply(cl_viz)

out <- NULL
for (analyzer in names(viz_list)) {
  out <- c(
    out,
    knitr::knit_expand(
      text = paste0(
        '\n{{analyzer}} {data-orientation=rows data-navmenu=\'Analyzer\'}',
        '\n=========================================',
        '\n\nRow {.tabset .tabset-fade}',
        '\n-----------------------------------------',
        '\n### Table',
        '\n```r}-tab}',
        '\ngrid.draw(combine(viz_list[[\'{{analyzer}}\']]$count_tab, viz_list[[\'{{analyzer}}\']]$normalized, along = 2))',
        '\n```',
        '\n\n### Chart',
        '\n```r}-chart}',
        '\ngrid.draw(viz_list[[\'{{analyzer}}\']]$chart)',
        '\n```'
      )
    )
  )
}