R/tmre_error_finder.R

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

#' @title tmre_error_finder
#'
#' @description Function to find incorrect Lot Numbers for TM complaints
#'
#' @param filename Filename of Excel workbook to write to. Defaults to tmre_checkMMMYYYY.xlsx.
#' MMMYYYY is the month and year.
#' @param write If TRUE, writes complaints to check to Excel Workbook. Defaults to TRUE.
#'
#' @return Returns list of dataframes either having wrong Lot Number format, or
#' Lot Numbers that have been requested but not received.
#'
#' @export

tmre_error_finder <- function(
  filename = NA,
  write = TRUE
) {

  df <- srms::tm_general_template(
    daterange = c(
      strftime(lubridate::floor_date(Sys.time(), 'month'),
               format = '%Y-%m-%d'),
      strftime(Sys.time(), format = '%Y-%m-%d')
    )
  )
  csname <- names(df)[grepl('*call.subject', tolower(names(df)))][1]
  call_subjs <- unique(tmre_lots$Call.Subject[tmre_lots$MTS == 0])

  check_list <- vector('list', length(call_subjs))

  for (cs in call_subjs) {
    check <- df %>%
      dplyr::filter_(
        paste0(csname, ' == "', cs, '"')
      )

    if (nrow(check) > 0) {
      formats <- tmre_lots %>%
        dplyr::filter(
          Call.Subject == cs
        ) %>%
        .$`Lot#.ID`

      for (format in formats) {
        len <- length(unlist(strsplit(format, '')))
        if (nrow(check) > 0) {
          if ('x' %in% unlist(strsplit(format, ''))) {
            xind <- (1:len)[unlist(strsplit(format, '')) == 'x']

            start <- paste(unlist(strsplit(format, ''))[1:(xind[1]-1)],
                           collapse = '')

            len_mask <- apply(
              check,
              1,
              function(x) length(unlist(strsplit(x[11], ''))) != len
            )

            len_mask[is.na(len_mask)] <- TRUE

            start_mask <- apply(
              check,
              1,
              function(x)
                paste(unlist(strsplit(x[11], ''))[1:(xind[1]-1)],
                      collapse = '') != start
            )

            if (toupper(unlist(strsplit(format, ''))[len]) != 'X') {
              end_mask <- apply(
                check,
                1,
                function(x)
                  toupper(unlist(strsplit(x[11], ''))[len]) != toupper(
                    unlist(strsplit(format, ''))[len])
              )
            } else {
              end_mask <- rep(FALSE, nrow(check))
            }

            mask <- (len_mask + start_mask + end_mask) > 0

            check <- check[mask, ]
          } else {
            check_mask <- apply(
              check,
              1,
              function(x)
                paste(unlist(strsplit(x[11], ''))[1:len],
                      collapse = '') != format
            )

            check <- check[check_mask, ]
          }
        }
      }
      check_list[[match(cs, call_subjs)]] <- check
    } else {
      check_list[[match(cs, call_subjs)]] <- check
    }
  }

  mts_subjs <- unique(tmre_lots$Call.Subject[tmre_lots$MTS == 1])
  mts_list <- vector('list', length(mts_subjs))
  for (cs in mts_subjs) {
    check <- df %>%
      dplyr::filter_(
        paste0(csname, ' == "', cs, '"')
      )

    if (nrow(check) > 0) {
      format <- tmre_lots %>%
        dplyr::filter(
          Call.Subject == cs
        ) %>%
        .$`Lot#.ID`

      end <- apply(
        check,
        1,
        function(x)
          paste(tail(unlist(strsplit(unlist(strsplit(x[11], '-'))[1], '')), 3),
                collapse = '') != format
      )

      mts_list[[match(cs, mts_subjs)]] <- check[end, ]
    } else {
      mts_list[[match(cs, mts_subjs)]] <- check
    }
  }

  final <- rbind(do.call('rbind', check_list), do.call('rbind', mts_list))
  final <- final[!is.na(final$`Lot Serial Number`), ]
  all_mask <- !grepl('*all lot*', tolower(final$`Lot Serial Number`))

  final <- final[all_mask, ]

  requested <- apply(
    final,
    1,
    function(x) grepl('*provided*|*requested*|request*', tolower(x[11]))
  ) %>% as.logical() | final[, 11] == '' | final[, 11] == 'N/A'

  if (write) {
    if (is.na(filename)) {
      filename <- file.path('~', 'reporting', 'monthly', 'Transfusion Medicine',
                            'errors', lubridate::year(Sys.time()),
                            strftime(Sys.time(), format = '%m-%b'),
                            paste0('tmre_errors_', strftime(Sys.time(), format = '%m_%b'), '.xlsx'))
    }

    wb <- openxlsx::createWorkbook()

    openxlsx::addWorksheet(
      wb = wb,
      sheetName = 'wrong format'
    )

    openxlsx::writeDataTable(
      wb = wb,
      sheet = 'wrong format',
      x = final[!requested, ]
    )

    openxlsx::addWorksheet(
      wb = wb,
      sheetName = 'requested'
    )

    openxlsx::writeDataTable(
      wb = wb,
      sheet = 'requested',
      x = final[requested, ]
    )

    openxlsx::saveWorkbook(
      wb = wb,
      file = filename,
      overwrite = TRUE
    )
  }

  return(
    list(wrong_format = final[!requested, ], requested = final[requested, ])
  )
}