Fuzzy Matching Script

In [1]:

knitr::opts_chunk$set(eval = FALSE)

Introduction

The COVID Sequencing project matches lab-submitted COVID test sequencing records with WDRS COVID test result records. Usually this matching process is accomplished by matching clinical accession numbers that are assigned to COVID test specimens by the testing lab and which remain attached to the specimen through the sequencing process. However, some sequencing records are submitted without the clinical accession number, or the clinical accession number that accompanies the sequencing record does not match any COVID test specimen clinical accession in the WDRS Flattened or Entire tables. For sequencing records that cannot match to a test specimen in WDRS via a clinical accession specimen id, patient demographics provide an alternative matching option.

The FUZZY_MATCHING script uses fuzzyjoin::stringdist_left_join() to perform optimal string alignment on patient name and date of birth data to match lab-submitted sequencing data to COVID test specimen records in the WDRS Flattened and Entire tables.

Setup

Libraries

In [2]:

library(tidyverse)
library(fuzzyjoin)
library(here)
library(lubridate)
library(readxl)
library(DBI)
library(odbc)
library(dtplyr)
library(fs)

Important Objects

This script uses several custom functions which are shared by other scripts in the Sequencing project. These shared custom functions are stored in the quality_filters.R script, which is called here using the source() function. The script also uses a table of

Three sources of data are imported into this script. Valid lineage data is brought into help assure data quality. Submitter sequencing records are imported from the Submissions/Fuzzy_Match/ subdirectory of project_folder, either the project directory on the net drive (test mode = FALSE) or the same folder in a local clone (test mode = TRUE). And finally, WDRS is queried for COVID test records which must be matched to the new sequencing data.

VOC.RDS contains the list of variants of concern and is needed to populate the SEQUENCE_VARIANT column. The lineages object is updated [how often] by the _________________ script. VOC.RDS is declared in the .gitignore file as the only .RDS object allowed to pass to GitHub, as it does not contain any secrets, and it must be updated in order for roster-generating scripts to run properly.

In [3]:

# read in r_creds.RDS
r_creds <-readRDS(file.path(Sys.getenv("USERPROFILE"), "Projects/Sequencing/Data_Objects", "r_creds.RDS"))

# Read in quality_filters
source(file.path(Sys.getenv("USERPROFILE"), "Projects/Sequencing/Roster_scripts/quality_filters.R"))

# Read in functions for performing fuzzy matching
source(file.path(Sys.getenv("USERPROFILE"), "Projects/Sequencing/Roster_scripts/fuzzy_matching_functions.R"))

# shared lab variable lists
lab_vars <- readRDS("Data_Objects/lab_variables.rds")

voc <- readRDS("Data_Objects/VOC/VOC.Rds")

lineages <- read_csv("Data_Objects/Lineages/Lineages.csv") %>%
  select(lineages = lineage_extracted)

valid_lineages <- lineages$lineages

# Appending Unassigned lineage to avoid for review
valid_lineages <- c(
  valid_lineages, 
  "UNASSIGNED",
  "Unassigned"
)

Submitter data

Data for fuzzy matching gets sent to the Fuzzy_Match folder in the Submissions subdirectory of the sequencing project. Each run of this script produces a saved_rows.csv file which contains rows that were not printed to any other file during the course of the run. While efforts are made to capture and funnel all of the data to some product in this script, this matching process is complex and saved_rows serves as a safety net to prevent data loss. saved_rows and the new files sent to fuzzy matching from the PHL and TEMPLATE_SUBMITTERS scripts are imported using readr::read_csv(), and compiled using plyr::rbind.fill(). Base R’s unique() removes duplicate rows, which may occur when cumulative files such as the PHL download are run repeatedly through a transformation script before this fuzzy matching process is performed.

Files imported in this code chunk are combined using plyr::rbind.fill() because at the time of writing this script, data sent from the template submitters and PHL processes were producing different sets of columns. the rbind.fill() function allows for two files with slightly different column to be combined; all the columns will be preserved and blank cells will be added for rows that did not originally contain columns from the other files.

As a part of this data import, a unique row id is assigned using tibble::rowid_to_column() to avoid generating duplication events when records lack any unique identifier such as a sequence clinical accession or sequence accession, as sometimes happens when failed sequencing records (which do not require a sequence accession) also lack a sequence clinical accession.

rows_printed: the empty object rows_printed is created here. Throughout the script, this object will receive the rowid’s of records that are printed to any file. This conveniently allows us to see (if running the script manually) how many rows fall to each of the various output. At the end of the script, any records from the original input data whose rowid is NOT in rows_printed is passed to a saved_rows file which is printed to a subfolder of the fuzzy matches submissions folder and read into the next fuzzy matching session. This file is almost always empty, but it is beneficial to regularly check it to see if and how many records are not being captured by the script. This may indicate some change in the submitter data being received.

In [4]:

# a list of the columns we want to bring into this process
# input columns for fuzzy matching data
fuzz_cols <- c("SEQUENCE_REASON",
      "GISAID_ID",
      "PANGO_LINEAGE",
      "FIRST_NAME",
      "LAST_NAME",
      "MIDDLE_NAME",
      "SUBMITTING_LAB",
      "DOB",
      "SPECIMEN_COLLECTION_DATE",
      "SEQUENCE_STATUS",
      "ALTERNATIVE_ID",
      "LAB_ACCESSION_ID")

# rows from the previous fuzzy match run that were not printed to any other file; a safety net to prevent data loss
saved_rows_file <- dir_ls("Submissions/Fuzzy_Match/rows_not_yet_printed")
if(length(saved_rows_file) > 0) {
  saved_rows <- saved_rows_file %>%
    map_df( ~ read_csv(
      .,
      col_types = cols(
        SEQUENCE_REASON = col_character(),
        GISAID_ID = col_character(),
        PANGO_LINEAGE = col_character(),
        FIRST_NAME = col_character(),
        LAST_NAME = col_character(),
        MIDDLE_NAME = col_character(),
        SUBMITTING_LAB = col_character(),
        DOB = col_character(),
        SPECIMEN_COLLECTION_DATE = col_character(),
        SEQUENCE_STATUS = col_character(),
        ALTERNATIVE_ID = col_character(),
        LAB_ACCESSION_ID = col_character()
      )
    )
    ) %>%
      plyr::rbind.fill() %>%
    select(all_of(fuzz_cols)) %>%
    unique()
  # if no inputs here, inititalize empty data frame
} else {
  saved_rows <- data.frame(matrix(ncol=length(fuzz_cols), nrow = 0)) %>% magrittr::set_colnames(fuzz_cols)
}

# new files produced by the PHL and template submitter script
fuzz_new_file <- dir_ls("Submissions/Fuzzy_Match", type = "file")
if(length(fuzz_new_file) > 0) {
  fuzz_new <- fuzz_new_file %>%
    map_df( ~ read_csv(
      .,
      col_types = cols(
        SEQUENCE_REASON = col_character(),
        GISAID_ID = col_character(),
        PANGO_LINEAGE = col_character(),
        FIRST_NAME = col_character(),
        LAST_NAME = col_character(),
        MIDDLE_NAME = col_character(),
        SUBMITTING_LAB = col_character(),
        DOB = col_character(),
        SPECIMEN_COLLECTION_DATE = col_character(),
        CASE_ID = col_character(),
        SEQUENCE_STATUS = col_character(),
        ALTERNATIVE_ID = col_character(),
        LAB_ACCESSION_ID = col_character()
      )
    )
    ) %>%
      plyr::rbind.fill() %>%
    select(all_of(fuzz_cols)) %>%
    unique()
  # if not inputs. initialize empty data frame
} else {
  fuzz_new <- data.frame(matrix(ncol=length(fuzz_cols), nrow = 0)) %>% magrittr::set_colnames(fuzz_cols)
}

# rbind.fill() adds saved_rows to the fuzz_new file, allowing for columns to be different between files. 
# create a unique row id using the index
fuzz <- fuzz_new %>% plyr::rbind.fill(saved_rows) %>%
  unique() %>%
  tibble::rowid_to_column()

rows_printed <- c()

print(nrow(fuzz))

# If no records for fuzzy matching, send out the email and 
# stop the script
if(nrow(fuzz) == 0) {
     sendmailR::sendmail(
    from = "",
    to = c(
      ""
    ),
    subject = "Sequencing - COVID Sequencing Fuzzy Match script complete",
    msg = paste0("Fuzzy matching script for ", today(), " is complete, there were no inputs to fuzzy matching."),
    headers = list("Reply-To" = ""),
    control = list(smtpServer = "")
  )
  
  stop("No inputs to fuzzy matching")
}

WDRS Data

Open connection to WDRS

IMPORTANT the variables used to connect to WDRS are held within conn_list.RDS, you will need to make your own private .RDS.

We do not include server connections in code uploaded to GitHub.

So: DO NOT alter the code used to open the connection to WDRS in any way that creates a security risk. Continue to treat this connection as a secret and store its variables in a .RDS object (or other external object that is excluded from Git commits) rather than calling them directly here.

In [5]:

# connect
connection <- DBI::dbConnect(odbc::odbc(), 
                             Driver = r_creds$conn_list[1], 
                             Server = r_creds$conn_list[2], 
                             Database = r_creds$conn_list[3], 
                             Trusted_connection = r_creds$conn_list[4], 
                             ApplicationIntent = r_creds$conn_list[5])

WDRS Entire table

WDRS demographics data for fuzzy matching

There are two different types of columns where name data is found in the entire table. The data is pulled into R using a SQL query. The custom function annihilate cleans the data to remove floating initials, punctuation, and extra spaces; check the Important Functions Wiki page in the repository for more information.

PATIENT__FIRSTNAME and FIRST_NAME (substitute LAST for last names) are both filled with patient name data, and sometimes a name is found in one column but not in another. Therefore, both columns are queried. In the code chunk ‘wdrs names’ below ‘wdrs_entire’, a single name column is created by filling in missing data with data present in the alternate column.

In [6]:

# wdrs_entire <- xfun::cache_rds({
  wdrs_entire <- dbGetQuery(
    connection,
    "SELECT Distinct CASE_ID,
      [PATIENT__FIRSTNAME] as FNAME,
      [PATIENT__LASTNAME] as LNAME,
      [FILLER__ORDER__NUM] as SpecimenId,
      [PATIENT__DATE__OF__BIRTH] as DOB_WDRS,
      [SPECIMEN__COLLECTION__DTTM] as COLLECTION_DATE_WDRS,
      [FIRST_NAME] as FIRST_NAME,
      [LAST_NAME] as LAST_NAME
  FROM [dbo].[DD_ELR_DD_ENTIRE] WHERE CODE = 'SARS'
  AND STATUS != '6' 
  AND WDRS__RESULT__SUMMARY != 'NEGATIVE'"
  ) 

  # clean up WDRS names, remove characters that are not alphanumeric, remove white spaces
  wdrs_entire_names <- wdrs_entire %>%
    mutate(FNAME = annihilate(wdrs_entire$FNAME),
           LNAME = annihilate(wdrs_entire$LNAME),
           SpecimenId = as.character(SpecimenId),
           FIRST_NAME = annihilate(wdrs_entire$FIRST_NAME),
           LAST_NAME = annihilate(wdrs_entire$LAST_NAME)) %>%
    unite(NAME_WDRS,
          c(FNAME, LNAME),
          remove = TRUE,
          na.rm = TRUE) %>%
    unite(ALT_NAME_WDRS,
          c(FIRST_NAME, LAST_NAME),
          remove = TRUE,
          na.rm = TRUE)
  
# },
# rerun = FALSE,
# file = "wdrs_query")

In [7]:

# Combine PATIENT NAME and NAME columns
wdrs_entire <- wdrs_entire_names %>%
   mutate(NAME_WDRS = case_when(
      NAME_WDRS == "" ~ ALT_NAME_WDRS,
      NAME_WDRS != "" ~ NAME_WDRS)
      )

# Get records where the PATIENT NAME and NAME columns differ
alt_wdrs_name <- filter(wdrs_entire, NAME_WDRS != ALT_NAME_WDRS) %>%
  mutate(NAME_WDRS = ALT_NAME_WDRS)

# Add rows using the alternate name, duplicating the other columns
wdrs_entire <- rbind.data.frame(wdrs_entire, alt_wdrs_name)

WDRS Flattened table

Sequencing results are entered into the flattened table, tied to the CASE_ID from the COVID test record found in the entire table. In order to prevent the entry of duplicate records to WDRS, we query the flattened table for sequence accession numbers tied to COVID test record CASE_ID’s, and use these data to deduplicate input data that may have been submitted repeatedly.

In [8]:

# wdrs_sa_flat <- xfun::cache_rds({
  wdrs_sa_flat <- dbGetQuery(
    connection,
    "SELECT DISTINCT CDC_N_COV_2019_SEQUENCE_ACCESSION_NUMBER,
     CDC_N_COV_2019_SEQUENCE_CLINICAL_ACCESSION_NUMBER,
     CASE_ID,
     BIRTH_DATE
     FROM [dbo].[DD_GCD_COVID_19_FLATTENED]
     "
  )
  
# },
# file = "wdrs_sa_flat")
  
# for fields that have multiple comma separated SEQUENCE_ACCESSION's split them by ","
wdrs_sa_flat_split <- unlist(str_split(wdrs_sa_flat[[1]], ","))

# omit any NA's
wdrs_sa_flat_clean <-
  wdrs_sa_flat_split[!is.na(wdrs_sa_flat_split)] %>%
  #for fields that have "hCoV-19/" appended to the beginning of the SEQUENCE_ACCESSION remove it by str_replace() with ""
  str_replace("hCoV-19/", "") %>%
  # trim off the white space resulting from str_split, this also gets rid of " " values
  str_trim("both")

# remove any values that are ""
wdrs_sa_flat_values <-
  wdrs_sa_flat_clean[wdrs_sa_flat_clean != ""]

In [9]:

# for fields that have multiple comma separated SEQUENCE_ACCESSION's split them by ","
wdrs_sca_flat_split <- unlist(str_split(wdrs_sa_flat[[2]], ","))

# omit any NA's
wdrs_sca_flat_clean <- wdrs_sca_flat_split[!is.na(wdrs_sca_flat_split)] %>%
#for fields that have "hCoV-19/" appended to the beginning of the SEQUENCE_ACCESSION remove it by str_replace() with ""
  str_replace("hCoV-19/", "") %>%
# trim off the white space resulting from str_split, this also gets rid of " " values  
  str_trim("both")

# remove any values that are ""
wdrs_sca_flat_values <- wdrs_sca_flat_clean[wdrs_sca_flat_clean != ""]

In [10]:

# some records in the WDRS ENTIRE table don't have a DOB, but that data is present for matching records 
# in the WDRS flattened table - replace DOB data with data from flattened table

wdrs_entire <- left_join(wdrs_entire, wdrs_sa_flat, by = 'CASE_ID')

wdrs_entire <- wdrs_entire %>% 
  mutate(DOB_WDRS = case_when((is.na(DOB_WDRS) & !is.na(BIRTH_DATE)) ~ BIRTH_DATE,
                              TRUE ~ DOB_WDRS)) 

# if the WDRS entire and WDRS flattened table have different DOB, add a duplicate record with the alternate DOB (same method used for alt name)
# Get records where the DOB_WDRS and BIRTH_DATE columns differ
alt_wdrs_dob <- filter(wdrs_entire, DOB_WDRS != BIRTH_DATE) %>%
  mutate(DOB_WDRS = BIRTH_DATE)

# Add rows using the alternate name, duplicating the other columns, remove unused columns
wdrs_entire <- rbind.data.frame(wdrs_entire, alt_wdrs_dob) %>% select(-CDC_N_COV_2019_SEQUENCE_ACCESSION_NUMBER,
                                                           -CDC_N_COV_2019_SEQUENCE_CLINICAL_ACCESSION_NUMBER, -BIRTH_DATE)

Initial Quality Checks

Fixing SA Format

In [11]:

# format GISAID ID - removing hcov-19 from the SA
fuzz_fix_sa_format <- fuzz %>%
  mutate(GISAID_ID = str_replace(GISAID_ID, "hCoV-19/", ""))

#code to remove sequence accessions with a bad format that was encountered with LabCorp specimens for a short time; obsolete, retaining in case of re-occurance
# fuzz_clean <- fuzz %>%
#   filter(!(GISAID_ID %in% wdrs_sa_flat_values),
#          !(str_detect(GISAID_ID, "USA/WA-CDC-WA-CDC-*")))
# 
# fuzz_wrong <- fuzz %>%
#   filter(str_detect(GISAID_ID, "USA/WA-CDC-WA-CDC-*")) 

# 
# # if(nrow(fuzz_wrong) > 0) {
# #   write_csv(fuzz_wrong, paste0(project_folder, 
# #                                       "//Fuzzy_matches//Fuzzy_Error_Checks//fuzzy_bad_SA_format_", 
# #                                       today(), 
# #                                       ".csv"))
# #   
# #   rows_printed <- rows_printed %>% append(fuzz_wrong$rowid)
# #   
# #   print(paste(length(rows_printed), "of", nrow(fuzz), "rows have been printed"))
# # }
# 
# 
# 

Missing Demographics

Before data can be filtered, one correction to date data for birth dates must be made. Excel dates have arrived in the birth date column and are not transformed to any known format in R when the file is read in using read_csv. The custom function convert_excel_date() transforms these 4-5 digit strings to mm-dd-yyyy format. See the Important Functions Wike page for more details.

In [12]:

#transform dates that are in excel format to yyyy-mm-dd. keep NA rows so that they are filtered along with other preprocessing errors

fuzz_fix_excel_dates <- fuzz_fix_sa_format %>%
  mutate(DOB = case_when(detect_date_format(DOB) ~ as.character(DOB),
                         str_detect(DOB, "^[[:digit:]]{4,5}$") ~ as.character(convert_excel_date(DOB)),
                         TRUE ~ DOB))
#   
# }

Pre-Match Quality Checks

Columns are added to the data that check for specific errors and add a 1 to the rows where the error check is positive. These error checks include the relevant checks from the roster_filters() function; see the Important Functions Wiki page for more details. It is important to note that the deduplication process for Fuzzy Matching does not involved the Sequence Clinical Accession as many rows arrive here without that identifier. We do however deduplicate both internally and against WDRS by sequence accession.

Rows with positive errors are filtered out at the end of this error check process and sent to For_Review/to_process_fuzzy_match/fuzzy_pre_match_quality_filter_today.csv”

In [13]:

# create columns for each condition that must be met in order for the data to be rostered to wdrs



fuzzy_pre_match_quality <- fuzz_fix_excel_dates %>%
  mutate(SEQUENCE_REASON = toupper(SEQUENCE_REASON))%>%
  mutate(SEQUENCE_STATUS = if_else(str_detect(PANGO_LINEAGE,"Unas"),"LOW QUALITY",toupper(SEQUENCE_STATUS)))%>%
  mutate(
    # check that GISAID_ID (sequence accession) doesn't show up more than once
    QA_SA_INT_DUPE = case_when(!(is.na(GISAID_ID) | GISAID_ID == "") & 
                                        GISAID_ID %in% GISAID_ID[duplicated(GISAID_ID)] ~ 1),
    # check that GISAID_ID (sequence accession) isn't already in WDRS
    QA_SA_WDRS_DUPE = case_when(GISAID_ID %in% wdrs_sa_flat_values ~ 1),
    # check that lineage is not NA or None and is in expected list
    QA_SEQ_VARIANT = case_when(str_detect(toupper(PANGO_LINEAGE), "NONE|^NA") |
                                      (!PANGO_LINEAGE %in% valid_lineages &
                                         !(is.na(PANGO_LINEAGE) | PANGO_LINEAGE == "")) ~ 1),
    # check that sequence status is COMPLETE, FAILED, or LOW QUALITY and
    # that GISAID_ID (sequence accession) exists/doesn't exist for various statuses
    QA_SEQ_STAT = case_when(is.na(SEQUENCE_STATUS) ~ 1,
                            !SEQUENCE_STATUS %in% c('COMPLETE', 'FAILED', 'LOW QUALITY') ~ 1,
                                   # error when status is complete but sa is missing,
                                   SEQUENCE_STATUS == "COMPLETE" & (is.na(GISAID_ID) | GISAID_ID == "") ~ 1,
                                    # error when status is not complete and sa is not missing
                                    SEQUENCE_STATUS %in% c("FAILED",
                                                           "NOT DONE",
                                                           "HIGH CT") & !(is.na(GISAID_ID) | GISAID_ID == "") ~ 1),
    # check that sequence reason is valid for the submitting lab
    QA_SEQ_REASON = case_when(SUBMITTING_LAB %in% lab_vars$cdc_labs & !(SEQUENCE_REASON %in% lab_vars$input_seq_reasons_cdc) |
        (!(SUBMITTING_LAB %in% c(lab_vars$cdc_labs, "PHL")) & !(SEQUENCE_REASON %in% lab_vars$input_seq_reasons_non_cdc)) |
        (SUBMITTING_LAB == "PHL" & !(SEQUENCE_REASON %in% lab_vars$input_seq_reasons_phl))
       ~ 1),
    # check that lineage exists/does not exist for various sequence statuses
    QA_SEQ_NOTES = case_when((SEQUENCE_STATUS == "COMPLETE") &
                                       (is.na(PANGO_LINEAGE)) ~ 1,
                             (SEQUENCE_STATUS == "FAILED") &
                                         (PANGO_LINEAGE != "") ~ 1),
    # check that record has name
    QA_NAME_NA = case_when(is.na(FIRST_NAME) & is.na(LAST_NAME) & is.na(MIDDLE_NAME) ~ 1,
                           str_detect(FIRST_NAME,"[[:digit:]]") | str_detect(LAST_NAME,"[[:digit:]]") | str_detect(MIDDLE_NAME,"[[:digit:]]") ~ 1),
    # check that record has DOB and is in the correct format
    QA_DOB_NA = case_when(is.na(DOB) ~ 1,
                          DOB == "1899-12-30" ~ 1,
                          !detect_date_format(DOB) ~ 1),
    # check that record has collection date and is in the correct format
    QA_COLLECT_DATE_NA = case_when(is.na(SPECIMEN_COLLECTION_DATE) ~ 1,
                                   is.na(lubridate::parse_date_time(SPECIMEN_COLLECTION_DATE, orders = c("mdY", "ymd", "Ymd"))) ~ 1)
  )  %>% 
  rowwise() %>%
  mutate(sum = sum(
    c_across(QA_SA_INT_DUPE:QA_COLLECT_DATE_NA),
    na.rm = TRUE
  ))

# print a table with sums of each error column for visibility

quality_check <- fuzzy_pre_match_quality %>% 
  select(QA_SA_INT_DUPE:QA_COLLECT_DATE_NA) %>%
  colSums(na.rm = TRUE)

quality_check

Print Pre-Match Errors

At this point, we will filter and print all records that generated a positive result for any of the error checks in the previous section. At this point, we will have captured the following errors in the data:

• GISAID_ID (sequence accession) doesn’t show up more than once
• GISAID_ID (sequence accession) isn’t already in WDRS
• lineage is not NA or None and is in expected list
• sequence status is COMPLETE, FAILED, or LOW QUALITY (not missing or other than one of these)
• GISAID_ID (sequence accession) exists or doesn’t exist according to the logic for sequence statuses: if COMPLETE, GISAID_ID is present. If LOW_QUALITY, GISAID_ID may or may not be present. If FAILED, GISAID_ID is not present. Code also applies this check to statuses “HIGH CT” and “NOT DONE”, although either of these statuses will also be caught as an error because the only status permitted for invalid sequence results should be ’FAILED”.
  • error when status is complete but sa is missing
  • error when status is not complete and sa is not missing
• sequence reason is valid for the submitting lab
• lineage exists or does not exist according to the logic for sequence statuses
• patient name is not missing
• DOB is not missing and is in a correct date format, and is NOT 1899-12-31, which may result when an excel date of 00000 is converted to yyyy-mm-dd
• specimen collection date is not missing and is in the correct format

fuzz_good_rows is the dataframe used to create rosters. We create it by filtering out all rows that generated an error, leaving behind only clean data.

In [14]:

# print a file containing rows with errors
fuzz_bad_rows <- fuzzy_pre_match_quality %>% 
  filter(sum > 0)

if(nrow(fuzz_bad_rows) > 0) {
    write_csv(fuzz_bad_rows %>% select(-sum, -rowid), file.path(
    "For_Review/to_process_fuzzy_match",
      paste0("fuzzy_pre_match_quality_filter_",
      today(),
      ".csv"
    )
    ), na = ""
  )
  
  rows_printed <- rows_printed %>% append(fuzz_bad_rows$rowid)
  print(paste(length(rows_printed), "of", nrow(fuzz), "rows have been printed"))
}

# split out the good data and pass it through to the rest of the script
fuzz_good_rows <- fuzzy_pre_match_quality %>%
  filter(sum == 0)

Clean Data Sent to Rosters

fuzz_good_rows receives two final transformations before it is matched to WDRS data.

The custom annihilate() function is applied to FIRST_NAME and LAST_NAME from submitter data to produce names in a standardized format (example: JANE_DOE). See the Important Functions Wiki page for details about custom functions.

The DOB and SEQUENCE_SPECIMEN_COLLECTION_DATE columns are transformed to a uniform yyyy-mm-dd format.

In [15]:

fuzzy_match_initial <- fuzz_good_rows %>% mutate(
  FNAME = annihilate(FIRST_NAME),
  LNAME = annihilate(LAST_NAME),
  DOB_SUBMITTER = lubridate::parse_date_time(DOB, orders = c("mdY", "ymd", "Ymd")),
  SEQUENCE_SPECIMEN_COLLECTION_DATE = lubridate::parse_date_time(SPECIMEN_COLLECTION_DATE, orders = c("mdY", "ymd", "Ymd"))
  ) %>%
  unite(NAME_SUBMITTER,
        c(FNAME, LNAME),
        remove = TRUE,
        na.rm = TRUE) %>%
  select(
    rowid,
    NAME_SUBMITTER,
    GISAID_ID,
    SEQUENCE_SPECIMEN_COLLECTION_DATE,
    DOB_SUBMITTER,
    PANGO_LINEAGE,
    SEQUENCE_REASON,
    SEQUENCE_STATUS,
    SUBMITTING_LAB,
    LAB_ACCESSION_ID
  ) %>%
  unique()

Fuzzy matching

Inexact matching between WDRS and submitter data relies on patient first and last name and date of birth. Additional matching based on specimen collection date is carried out after the initial matches based on demographics are identified.

First, records are grouped by the year of the date of birth of the patient, extracted from the DOB_SUBMITTER column for submitter data and the DOB_WDRS column for WDRS data to be matched.

An alternative name column is created for the submitter data, consisting of name data flipped so that the order of the names is last_first. Sometimes the name order in either submitter or wdrs data is flipped and so we match on both name orders to capture these instances.

Submitter data is split into a list of dataframes, each list containing records of patients grouped by the year of their birth.

The custom fuzzy_match_name_flip() function is applied to this list of submitter records. This function first blocks the data based on the birth year of the patient, splitting out WDRS records where the birth year of the patient matches the birth year of the submitter records to be matched. Then the function applies stringdist_left_join(), which matches names using optimal string alignment to look for near matches. The output includes a distance column with data on the distance between the submitter and WDRS names for matched records. A maximum distance of 3 characters is allowed here.

Additional matching columns are provided to allow filtering on matching date of birth and matching specimen collection date. Because we have noticed date of birth errors and unreliable specimen collection date data, we generate files for manual review that contain rows unable to be matched perfectly to WDRS using name and date of birth.

In [16]:

# Block input on DOB year to reduce possible matches, and improve speed
# Break input into groups of records with the same DOB year
# and use parallelization to run fuzzy matching across each of these groups
wdrs_entire$year <- lubridate::year(wdrs_entire$DOB_WDRS)
fuzzy_match_initial$year <- lubridate::year(fuzzy_match_initial$DOB_SUBMITTER)

# Create groups based on DOB year
fuzzy_match_initial <- fuzzy_match_initial %>%                                        
  group_by(year) %>%
  dplyr::mutate(group_num = cur_group_id())

# Add second version of the name with first and last name switched to account
# for switching of fields
fuzzy_match_initial$NAME_SUBMITTER_2 <- paste0(str_replace(fuzzy_match_initial$NAME_SUBMITTER, ".*_", ""),
                                               "_", str_replace(fuzzy_match_initial$NAME_SUBMITTER, "_.*", ""))

# split input records into separate tables per group
fuzzy_split <- split(fuzzy_match_initial, f = fuzzy_match_initial$group_num)

# print size of each group
lapply(fuzzy_split, dim)


# apply the fuzzy matching function in parallel across 7 of 8 cores. Can use all cores if not performing other tasks. 
library(parallel)
numCores  = round(parallel::detectCores() * .85)
cl <- makePSOCKcluster(numCores)

# export the necessary elements of the local environment to all the cores
system.time(clusterExport(
  cl = cl,
  varlist = c("fuzzy_split", "wdrs_entire"),
  envir = .GlobalEnv
))

# Run fuzzy matching
system.time(
  fuzzy_matches_wdrs <- parLapply(cl, fuzzy_split, fuzzymatch_name_flip) %>%
    bind_rows()
)

stopCluster(cl)

Transformations and Post-matching Quality Filters

Now that the submitter records have been assigned possible matches from WDRS, we apply final transformations and split out matches that contain errors.

modify date types

All date types are converted to the roster date format mm/dd/yyyy

In [17]:

fuzzy_matches_wdrs <- fuzzy_matches_wdrs %>% 
  mutate(COLLECTION_DATE_WDRS = as.character(format(
    as.Date(COLLECTION_DATE_WDRS), "%m/%d/%Y"
  ))) %>%
  mutate(SEQUENCE_SPECIMEN_COLLECTION_DATE = as.character(format(
    as.Date(SEQUENCE_SPECIMEN_COLLECTION_DATE), "%m/%d/%Y"
  ))) %>%
  mutate(DOB_SUBMITTER = as.character(format(
    as.Date(DOB_SUBMITTER), "%m/%d/%Y"
  ))) %>%
   mutate(DOB_WDRS = as.character(format(
    as.Date(DOB_WDRS), "%m/%d/%Y"
  )))

fuzzy_match_initial <- fuzzy_match_initial %>%
   mutate(SEQUENCE_SPECIMEN_COLLECTION_DATE = as.character(format(
    as.Date(SEQUENCE_SPECIMEN_COLLECTION_DATE), "%m/%d/%Y"
  ))) %>%
  mutate(DOB_SUBMITTER = as.character(format(
    as.Date(DOB_SUBMITTER), "%m/%d/%Y"
  )))

Filter data on matching DOB

Only possible matches with a perfectly matched date of birth are accepted. We discard matches generated by the fuzzy matching function where the name was a match but the date of birth is different.

This filter is easy to apply now; date formats require no modification because they have already been cleaned.

In [18]:

# filter out rows that have a dob that doesn't match any matching demographic rows in WDRS
fuzzy_dob_match <- fuzzy_matches_wdrs %>%
  mutate(DOB_MATCH = case_when(DOB_SUBMITTER == DOB_WDRS ~ "match"))

fuzzy_dob_filtered <- fuzzy_dob_match %>% filter(DOB_MATCH == 'match')

No CASE_ID assigned

Some submitter records might not have been assigned any matches from WDRS. Here, we split out these records as well as records for which only “bad” (non-matched date of birth) matches were assigned to the object did_not_match and printed to the Fuzzy_Matches/ subdirectory using the print_rosters() function, after being transformed to roster format.

the roster_filters() function is not applied here, as the error checks it performs are redundant with checks performed earlier in this script. In order to facilitate the use of the print_rosters() function, a dummy “sum” column is supplied, populated with 0’s.

In [19]:

# this code chunk uses the roster_filters() function, but it modifies the output heavily so that a file is printed that combines dob-missing or error rows and does not include errors that do not pertain to fuzzy matching or to this particular file. 

# print for review
did_not_match <- fuzzy_dob_match %>%
  filter(is.na(CASE_ID) | is.na(DOB_MATCH),
         !(rowid %in% fuzzy_dob_filtered$rowid))

did_not_match <- did_not_match %>%  mutate(
    CASE_ID = "",
    SEQUENCE_REASON = case_when(
      (SUBMITTING_LAB %in% lab_vars$cdc_labs &
        SEQUENCE_REASON %in% lab_vars$output_seq_reasons_cdc) ~ SEQUENCE_REASON,
      (!(SUBMITTING_LAB %in% c(lab_vars$cdc_labs, "PHL")) &
        SEQUENCE_REASON %in% lab_vars$output_seq_reasons_non_cdc) ~ SEQUENCE_REASON,
      (SUBMITTING_LAB == "PHL" &
        SEQUENCE_REASON %in% lab_vars$output_seq_reasons_phl) ~ SEQUENCE_REASON,
      (SUBMITTING_LAB %in% c(lab_vars$cdc_labs, "PHL") &
        SEQUENCE_REASON %in% lab_vars$seq_reason_sent_surveillance) ~ "SENTINEL SURVEILLANCE",
      (SEQUENCE_REASON %in% lab_vars$seq_reason_outbreak) ~ "OUTBREAK"
    ),
    SEQUENCE_LAB = SUBMITTING_LAB,
    SEQUENCE_SGTF = "",
    SEQUENCE_SPECIMEN = "YES",
    SEQUENCE_DATE = "",
    SEQUENCE_REPOSITORY = "GISAID",
    SEQUENCE_ACCESSION = case_when(SEQUENCE_STATUS == "FAILED" ~ "",
                                   SEQUENCE_STATUS == "COMPLETE" ~ GISAID_ID),
    SEQUENCE_CLINICAL_ACCESSION = as.character(LAB_ACCESSION_ID),
    COLLECTION_DATE_WDRS = "",
    SEQUENCE_REVIEWED = "",
    SEQUENCE_EPI_ISL = "",
    SEQUENCE_ROSTER_PREPARE_DATE = format(today(), "%m/%d/%Y")
  ) %>%
  mutate(SEQUENCE_VARIANT = case_when(PANGO_LINEAGE %in% voc ~ PANGO_LINEAGE,
                                      TRUE ~ "")) %>%
  mutate(SEQUENCE_NOTES = case_when(
    !is.na(PANGO_LINEAGE) ~ paste0(
      "Lineage identified as ",
      PANGO_LINEAGE,
      " on ",
      today(),
      ". Lineage assignments may change over time."
    ),
    is.na(PANGO_LINEAGE) ~ ""
  )) %>%
  mutate(Case.Note = "Case created and sequence data added through manual process.") %>%
  mutate(NAME_SUBMISSION = NAME_SUBMITTER,
         DISTANCE_NAME = "",
         NAME_WDRS = "") %>%
  mutate(SEQUENCE_VARIANT_OPEN_TEXT = PANGO_LINEAGE) %>%
  mutate(sum = "0") %>%
  select(
    CASE_ID,
    SEQUENCE_SGTF,
    SEQUENCE_SPECIMEN,
    SEQUENCE_DATE,
    SEQUENCE_REASON,
    SEQUENCE_LAB,
    SEQUENCE_STATUS,
    SEQUENCE_REPOSITORY,
    SEQUENCE_ACCESSION,
    SEQUENCE_EPI_ISL,
    SEQUENCE_VARIANT_OPEN_TEXT,
    SEQUENCE_CLINICAL_ACCESSION,
    SEQUENCE_SPECIMEN_COLLECTION_DATE,
    SEQUENCE_ROSTER_PREPARE_DATE,
    SEQUENCE_NOTES,
    SEQUENCE_REVIEWED,
    Case.Note,
    NAME_SUBMITTER,
    DOB = DOB_SUBMITTER,
    DISTANCE_NAME,
    NAME_WDRS,
    COLLECTION_DATE_WDRS,
    rowid
  ) %>%
  unique() %>%
  mutate(sum = 0)


fuzzy_match_successful <- filter(fuzzy_dob_filtered, !rowid %in% did_not_match$rowid) %>%
  select(-year.x, -year.y, -group_num)

print_roster(did_not_match, for_review = TRUE)

fuzzy_match_successful_clean <- fuzzy_match_successful %>%
  subset(!duplicated(fuzzy_match_successful %>% select(-NAME_WDRS)))

rows_printed <- rows_printed %>% append(did_not_match$rowid)
print(paste(length(rows_printed), "of", nrow(fuzz), "rows have been printed"))

Fuzzy Roster Transformations

Here, fuzzy match data is transformed to the schema that Data Support has agreed to review, and columns that belong in the roster are selected.

The lab_vars object contains a list of sequence reasons that are used here to assign sequence reasons matched to three different submitter categories. In order to understand these, inspect the lab_vars list pulled into the environment at the beginning of the script.

Another object used here that is imported from outside this script is the voc list of variants of concern. Visit the Lineages section of Import Data at the beginning of this script for details.

In [20]:

fuzzy_match_transform <- fuzzy_match_successful %>%
  mutate(
    SEQUENCE_REASON = case_when(
      (SUBMITTING_LAB %in% lab_vars$cdc_labs &
        SEQUENCE_REASON %in% lab_vars$output_seq_reasons_cdc) ~ SEQUENCE_REASON,
      (!(SUBMITTING_LAB %in% c(lab_vars$cdc_labs, "PHL")) &
        SEQUENCE_REASON %in% lab_vars$output_seq_reasons_non_cdc) ~ SEQUENCE_REASON,
      (SUBMITTING_LAB == "PHL" &
        SEQUENCE_REASON %in% lab_vars$output_seq_reasons_phl) ~ SEQUENCE_REASON,
      (SUBMITTING_LAB %in% c(lab_vars$cdc_labs, "PHL") &
        SEQUENCE_REASON %in% lab_vars$seq_reason_sent_surveillance) ~ "SENTINEL SURVEILLANCE",
      (SEQUENCE_REASON %in% lab_vars$seq_reason_outbreak) ~ "OUTBREAK"
    ),
    SEQUENCE_LAB = SUBMITTING_LAB,
    SEQUENCE_SGTF = "",
    SEQUENCE_SPECIMEN = "YES",
    SEQUENCE_DATE = "",
    SEQUENCE_REPOSITORY = "GISAID",
    SEQUENCE_ACCESSION = case_when(SEQUENCE_STATUS == "FAILED" ~ "",
                                   SEQUENCE_STATUS == "COMPLETE" ~ GISAID_ID),
    SEQUENCE_CLINICAL_ACCESSION = as.character(SpecimenId),
    SEQUENCE_REVIEWED = "",
    SEQUENCE_EPI_ISL = "",
    SEQUENCE_ROSTER_PREPARE_DATE = format(today(), "%m/%d/%Y")
  ) %>%
  mutate(SEQUENCE_VARIANT = case_when(PANGO_LINEAGE %in% voc ~ PANGO_LINEAGE,
                                      TRUE ~ "")) %>%
  mutate(SEQUENCE_NOTES = case_when(
    !is.na(PANGO_LINEAGE) ~ paste0(
      "Lineage identified as ",
      PANGO_LINEAGE,
      " on ",
      today(),
      ". Lineage assignments may change over time."
    ),
    is.na(PANGO_LINEAGE) ~ ""
  )) %>%
  mutate(Case.Note = "External data question package updated by COVID19 Sequencing Roster.") %>%
  mutate(NAME_SUBMISSION = NAME_SUBMITTER) %>%
  mutate(SEQUENCE_VARIANT_OPEN_TEXT = PANGO_LINEAGE) %>%
  select(
    rowid,
    CASE_ID,
    SEQUENCE_SGTF,
    SEQUENCE_SPECIMEN,
    SEQUENCE_DATE,
    SEQUENCE_REASON,
    SEQUENCE_LAB,
    SEQUENCE_STATUS,
    SEQUENCE_REPOSITORY,
    SEQUENCE_ACCESSION,
    SEQUENCE_EPI_ISL,
    SEQUENCE_VARIANT_OPEN_TEXT,
    SEQUENCE_CLINICAL_ACCESSION,
    SEQUENCE_SPECIMEN_COLLECTION_DATE,
    SEQUENCE_ROSTER_PREPARE_DATE,
    SEQUENCE_NOTES,
    SEQUENCE_REVIEWED,
    Case.Note,
    COLLECTION_DATE_WDRS,
    NAME_SUBMITTER,
    DOB = DOB_SUBMITTER,
    DISTANCE_NAME = distance,
    NAME_WDRS
  ) %>%
  unique()

Collection Date Filter

Filter Data on 14 Day Window

Now that collection dates are formatted, the interval in days is calculated between WDRS and submitter sequencing data. Rows with collection dates outside 14 days are filtered and sent to a for review folder. For most of these, there will be another possible match where the collection date was within the acceptable window. We address records where there is only a mismatched collection date in the next section.

In [21]:

fuzzy_match_transform <- fuzzy_match_transform %>%
  # calculate the interval in days between collection dates in submitter and wdrs data
  mutate(int = interval(
    mdy(SEQUENCE_SPECIMEN_COLLECTION_DATE),
    mdy(COLLECTION_DATE_WDRS)
  ),
  COLLECTION_DATE_DISTANCE = time_length(int, unit = "day")) %>%
  select(-c(int)) %>%
  unique()

# remove rows where the distance is greater than 14 days
fuzzy_colldate_filtered <- fuzzy_match_transform  %>% 
  filter(!is.na(COLLECTION_DATE_DISTANCE) &
           abs(COLLECTION_DATE_DISTANCE) <= 14 &
           !is.na(SEQUENCE_SPECIMEN_COLLECTION_DATE))

Collection Date Mismatch

Some matched records with a collection date difference outside 14 days are the only available match for a sequencing result. We split these out for manual review so that they are not lost, and add them back to the data for filtering and rostering.

In [22]:

# get records where the specimen collection date and wdrs collection date
# fell outside the 14 day window, and which are not recorded elsewhere

fuzzy_colldate_mismatch <- fuzzy_match_transform %>%
filter(!rowid %in% fuzzy_colldate_filtered$rowid) %>%
  unique()

# add records with collection date mismatch and no other match back into the table of matches
fuzzy_colldate_evaluated <- rbind(fuzzy_colldate_filtered, fuzzy_colldate_mismatch) %>% as.data.frame() %>%
  mutate(QA_COLLECT_DATE = case_when(is.na(COLLECTION_DATE_DISTANCE) ~ 1,
                                     abs(COLLECTION_DATE_DISTANCE) > 14 ~ 1)) 

If there are two possible matches with the same collection date and same case ID but different sequence clinical accessions, match to patient level (get rid of sequence clinical accession)

In [23]:

fuzzy_sca_count <- fuzzy_colldate_evaluated %>% 
  group_by(CASE_ID, SEQUENCE_ACCESSION) %>%
  summarise(count = n_distinct(SEQUENCE_CLINICAL_ACCESSION) )

# join the counts back to the rest of the data
join_counts <- left_join(fuzzy_colldate_evaluated, fuzzy_sca_count, by = c("CASE_ID", "SEQUENCE_ACCESSION"))  %>%
  arrange(COLLECTION_DATE_DISTANCE) %>%
  select(-COLLECTION_DATE_DISTANCE)

Case Counts

In cases where there are multiple sequence clinical accessions from WDRS are tied to a single unique case id + sequence accession combination, implying that the algorithm cannot distinguish between the sequence clinical accession is dropped and the record is matched to the patient level only.

In [24]:

# if there is >1 SCA per unique case_id + SA, remove all SCA from that case_id 
fuzzy_cleaned <- join_counts %>%
  mutate(SEQUENCE_CLINICAL_ACCESSION = if_else(count > 1, "", SEQUENCE_CLINICAL_ACCESSION))

# deduplicate the records so that they are matched to only the patient level, but keep the WDRS collection date for error checking
fuzzy_cleaned <- fuzzy_cleaned[!duplicated(fuzzy_cleaned %>% select(-COLLECTION_DATE_WDRS)),]

fuzzy_case_counts <-  fuzzy_cleaned %>%
  subset(!duplicated(fuzzy_cleaned %>% select(rowid:Case.Note))) %>%
  select(-count)

Print Rosters

Rosters are split out from fuzzy_case_counts based on match quality.

Perfect Matches

Some of the rows that have been matched to case id’s using demographics are ready to be sent to WDRS along with the rest of the roster. These are specimens where there is a perfect match between PHL and WDRS data for name, date of birth, and collection date of less than 14 days distance.

In [25]:

#perfect matches: send to write_roster_here
fuzzy_matched_perfect <- fuzzy_case_counts %>%
  # select only perfect name matches
  filter(DISTANCE_NAME == 0) %>%
  unique() %>% 
  mutate(QA_MULTIPLE_MATCH = case_when(rowid %in% rowid[duplicated(rowid)] ~ 1))

# apply roster filters
fuzzy_perfect <-fuzzy_matched_perfect %>%
  rowwise() %>%
    mutate(sum = sum(
      c_across(QA_COLLECT_DATE:QA_MULTIPLE_MATCH),
      na.rm = TRUE
    )
    ) 
  
print(fuzzy_perfect %>% 
    select(QA_COLLECT_DATE:QA_MULTIPLE_MATCH) %>%
    colSums(na.rm = TRUE))

# use the custom print_roster function; this will be modified to also print a roster of data with errors
# Fuzzy perfects are sent to "write_roster_here" and will go through Roster Compile script
# Fuzzy perfects with errors are sent to For_Review
print_roster(fuzzy_perfect, for_review = FALSE)
print_error_rows(fuzzy_perfect, roster_now = TRUE)

rows_printed <- rows_printed %>% append(unique(fuzzy_perfect$rowid))
print(paste(length(rows_printed), "of", nrow(fuzz), "rows have been printed"))

# remove matched records from table
fuzzy_case_counts <- filter(fuzzy_case_counts, !rowid %in% fuzzy_perfect$rowid)

Fuzzy1

Roster now: records with a name distance of 1 and a matching date of birth AND specimen collection date within the 14 day window.

In [26]:

# fuzzy 1 rows are rows where the best match was a name distance of 1
fuzzy1 <- fuzzy_case_counts %>% filter(DISTANCE_NAME == 1) %>% 
  unique() %>%
  # this is just for the convenience of anyone manually reviewing an output file to check matches
  arrange(SEQUENCE_ACCESSION) %>%
  mutate(QA_MULTIPLE_MATCH = case_when(rowid %in% rowid[duplicated(rowid)] ~ 1))

fuzzy1_roster_now <- fuzzy1 %>% 
  rowwise() %>%
    mutate(sum = sum(
      c_across(QA_COLLECT_DATE:QA_MULTIPLE_MATCH),
      na.rm = TRUE
    )
    )
  
print(fuzzy1 %>% 
    select(QA_COLLECT_DATE:QA_MULTIPLE_MATCH) %>%
    colSums(na.rm = TRUE))

# Fuzzy1 records are sent to "write_roster_here" and will go through Roster Compile script
# Fuzzy1 records with errors are sent to For_Review
print_roster(fuzzy1_roster_now, for_review = FALSE)

print_error_rows(fuzzy1_roster_now, roster_now = TRUE)

rows_printed <- rows_printed %>% append(unique(fuzzy1_roster_now$rowid))
print(paste(length(rows_printed), "of", nrow(fuzz), "rows have been printed"))

# remove matched records from table
fuzzy_case_counts <- filter(fuzzy_case_counts, !rowid %in% fuzzy1_roster_now$rowid)

Fuzzy2

Records with a name distance of 2 will be sent to the fuzzy matches folder for manual review.

In [27]:

fuzzy2 <- fuzzy_case_counts %>% 
  filter(DISTANCE_NAME == 2) %>% 
    mutate(SEQUENCE_CLINICAL_ACCESSION = case_when(is.na(SEQUENCE_SPECIMEN_COLLECTION_DATE) ~ "")) %>%
    mutate(SEQUENCE_ROSTER_PREPARE_DATE = format(today(), "%m/%d/%Y")) %>%
    mutate(SEQUENCE_EPI_ISL = "") %>%
  unique() %>%
  arrange(SEQUENCE_ACCESSION) %>% 
  mutate(QA_MULTIPLE_MATCH = case_when(rowid %in% rowid[duplicated(rowid)] ~ 1)) %>%
  rowwise() %>%
    mutate(sum = sum(
      c_across(QA_COLLECT_DATE:QA_MULTIPLE_MATCH),
      na.rm = TRUE
    )
    )

print(fuzzy2 %>% 
    select(QA_COLLECT_DATE:QA_MULTIPLE_MATCH) %>%
    colSums(na.rm = TRUE))


print_roster(fuzzy2, for_review = TRUE)

print_error_rows(fuzzy2)

rows_printed <- rows_printed %>% append(unique(fuzzy2$rowid))
print(paste(length(rows_printed), "of", nrow(fuzz), "rows have been printed"))

# remove matched records from table
fuzzy_case_counts <- filter(fuzzy_case_counts, !rowid %in% fuzzy2$rowid)

Fuzzy3

Records with a name distance of 3 will be sent to the fuzzy matches folder for manual review.

In [28]:

fuzzy3 <- fuzzy_case_counts %>% 
  filter(DISTANCE_NAME == 3) %>% 
      mutate(SEQUENCE_CLINICAL_ACCESSION = case_when(is.na(SEQUENCE_SPECIMEN_COLLECTION_DATE) ~ "")) %>%
      mutate(SEQUENCE_ROSTER_PREPARE_DATE = format(today(), "%m/%d/%Y")) %>%
      mutate(SEQUENCE_EPI_ISL = "") %>%
  unique() %>%
  arrange(SEQUENCE_ACCESSION) %>% 
  mutate(QA_MULTIPLE_MATCH = case_when(rowid %in% rowid[duplicated(rowid)] ~ 1)) %>%
  rowwise() %>%
    mutate(sum = sum(
      c_across(QA_COLLECT_DATE:QA_MULTIPLE_MATCH),
      na.rm = TRUE
    )
    )

print(fuzzy3 %>% 
    select(QA_COLLECT_DATE:QA_MULTIPLE_MATCH) %>%
    colSums(na.rm = TRUE))

print_roster(fuzzy3, for_review = TRUE)

print_error_rows(fuzzy3)

rows_printed <- rows_printed %>% append(unique(fuzzy3$rowid))
print(paste(length(rows_printed), "of", nrow(fuzz), "rows have been printed"))

# remove matched records from table
fuzzy_case_counts <- filter(fuzzy_case_counts, !rowid %in% fuzzy3$rowid)

Wrap-UP

Saved Rows

Any records with rowid’s not printed to other files are sent to the rows_not_yet_printed subfolder of the Fuzzy Matches submissions folder in the saved_rows file.

In [29]:

old_saved_delete <- dir_ls("Submissions/Fuzzy_Match/rows_not_yet_printed")

file_delete(old_saved_delete)

fuzz_saved <- fuzz %>% filter(!(rowid %in% rows_printed))

write_csv(fuzz_saved, paste0("Submissions//Fuzzy_Match//rows_not_yet_printed//saved_rows_", today(), ".csv"))

Move Files

Input files are moved to the Completed folder.

In [30]:

files_to_move <-  dir_ls(paste0("Submissions/Fuzzy_Match"), type = "file")

new_file_names <- paste0("Completed_Submissions/Fuzzy_Match/", basename(files_to_move))

file_move(files_to_move, new_file_names)

Completed Email

Alerts are compiled and an email is sent with details about the files produced by the script.

In [31]:

all_fuzzy_files <- dir_ls("write_roster_here") %>% str_subset("fuzzy")
all_fuzzy_files <- c(all_fuzzy_files, dir_ls("For_Review") %>% str_subset("fuzzy"))
all_fuzzy_files <- c(all_fuzzy_files, dir_ls("For_Review/to_process_fuzzy_match") %>% str_subset("fuzzy"))
all_fuzzy_files <- c(all_fuzzy_files, dir_ls("Fuzzy_matches") %>% str_subset("fuzzy"))
all_fuzzy_files <-  c(all_fuzzy_files, dir_ls("Fuzzy_matches/Fuzzy_Error_Checks") %>% str_subset("fuzzy"))
all_fuzzy_files <-  c(all_fuzzy_files, dir_ls("Fuzzy_matches") %>% str_subset("did_not_match"))


today_fuzzy_files <- all_fuzzy_files[str_detect(all_fuzzy_files, as.character(today()))] %>% unique()

today_fuzzy_review_files1 <- today_fuzzy_files %>% str_extract("For_Review.*") %>% na.omit() %>% as.character()
today_fuzzy_review_files2 <- today_fuzzy_files %>% str_extract("Fuzzy_matches.*") %>% na.omit() %>% as.character()
today_fuzzy_review_files <- c(today_fuzzy_review_files1, today_fuzzy_review_files2)
today_fuzzy_roster_files <- today_fuzzy_files %>% str_extract("write_roster_here.*") %>% na.omit() %>% as.character()

# initialize message
fuzzy_email_message <- paste("Fuzzy matched files were printed for COVID Sequencing data for", format(today(), "%m/%d/%Y"), 
                                    "and are ready for manual review. \n")



# if there files that are ready to be added to the roster
if (length(today_fuzzy_roster_files) > 0) {
  today_fuzzy_roster_file_names <- paste(unlist(today_fuzzy_roster_files), collapse='\n')
  fuzzy_email_message <- paste0(fuzzy_email_message,"\n\n" , "There were a total of ", length(today_fuzzy_roster_files), " file(s) written today that contain records that could be exactly matched to records in WDRS and are ready to be added to the roster. These files can be found at: ", "\n", today_fuzzy_roster_file_names)
}

# if there files that are ready to be added to the roster
if (length(today_fuzzy_review_files) > 0) {
    today_fuzzy_review_file_names <- paste(unlist(today_fuzzy_review_files), collapse='\n')
  fuzzy_email_message <- paste0(fuzzy_email_message,"\n\n" , "There were a total of ", length(today_fuzzy_review_files), " file(s) written today that require manual review. These files can be found at: ", "\n", today_fuzzy_review_file_names)
}


# Finalize message
fuzzy_email_message <- paste0(fuzzy_email_message, "\n\n", "Note: This is an automated message. Please enable your outlook to include extra line breaks to view this message in its proper format.", "\n\n", "This message is in development, and will be updated. If you see any errors reach out to DIQA. Thanks!")

In [32]:

# send email notifying that fuzzy matching has completed
  sendmailR::sendmail(
    from = "",
    to = c(
      ""
    ),
    subject = "Sequencing - COVID Sequencing Fuzzy Match script complete",
    msg = fuzzy_email_message,
    headers = list("Reply-To" = ""),
    control = list(smtpServer = "")
  )

Update fuzzy for review running list

In [33]:

# read in running file
running_list <- read_csv("For_Review/running_lists/fuzzy_for_review_records.csv", col_types = cols(.default = "c") )

# Read in any fuzzy perfect/fuzzy1/fuzzy2/fuzzy3 error row files from today
fuzzy_review_files <- dir_ls("For_Review", type="file") %>% str_subset("fuzzy")

# only today
fuzzy_review_files <- fuzzy_review_files[str_detect(fuzzy_review_files, as.character(today()))] %>% unique()

# Create empty dataframe
fuzzy_other_review <- data.frame()

if(length(fuzzy_review_files) > 0) {
  
for (i in 1:length(fuzzy_review_files)){
  
temp_data <- read_csv(fuzzy_review_files[i], col_types = cols(.default = "c"))
temp_data<-temp_data %>%
mutate(File_PATH=fuzzy_review_files[i])
fuzzy_other_review <- bind_rows(fuzzy_other_review, temp_data)
}
}

fuzz_bad_rows <- fuzz_bad_rows %>% mutate(across(everything(), as.character))
did_not_match <- did_not_match %>% mutate(across(everything(), as.character))

# Combine all records
running_list_updated <-bind_rows(fuzzy_other_review, fuzz_bad_rows, did_not_match, running_list)

# Make sure sequence accession is filled out
running_list_updated <- running_list_updated %>% mutate(SEQUENCE_ACCESSION = case_when(is.na(SEQUENCE_ACCESSION) ~ GISAID_ID, 
                                                                                      (!(is.na(SEQUENCE_ACCESSION)) ~SEQUENCE_ACCESSION)))
# Flag records now in WDRS
running_list_updated <- running_list_updated %>% mutate(WDRS_complete = ifelse(SEQUENCE_ACCESSION %in% wdrs_sa_flat_values, "1", "0"))%>%distinct(SEQUENCE_ACCESSION, .keep_all = TRUE)

wdrs_complete <- running_list_updated %>% filter(WDRS_complete==1)%>%distinct(SEQUENCE_ACCESSION)
manual_review_total <- running_list_updated %>% filter(WDRS_complete==0)%>%distinct(SEQUENCE_ACCESSION)

# Write updated list
write.csv(running_list_updated, file.path(paste0("For_Review/running_lists/fuzzy_for_review_records.csv")), na="",row.names = FALSE)


# Send email with review results

  email_from <- ""
  email_to <- ""
  email_subj <- "Sequencing - Fuzzy For Review Summary Automated Email"
  
  email_body <- paste(
  "Overview: \n \n",
  (nrow(manual_review_total)), "records pending manual review or roster. \n",
  (nrow(wdrs_complete)), "records completed to date.\n"
  
  )

# send it
sendmailR::sendmail(from = email_from,
                    to = email_to,
                    subject = email_subj,
                    msg = email_body,
                    headers= list("Reply-To" = email_from),
                    control = list(smtpServer = ""))