R/mod_data_model_detection.R

In ReviewR: A Light-Weight, Portable Tool for Reviewing Individual Patient Records

# Helper Functions ----
#' user_table
#'
#' @param table_map A [dplyr::tibble], generated by [mod_data_model_detection] containing user database 
#' tables and fields mapped to the determined CDM.
#' @param db_con A [DBI::dbConnect] object that is created through user interaction with the Setup Tab
#' @param desired_cdm_table A string containing the table name in the desired CDM.
#' 
#' @keywords internal
#'  
#' @importFrom magrittr %>%
#' @importFrom dplyr distinct select filter tbl pull
#' @importFrom rlang .data
#'
#' @return A SQL data source [dplyr::tbl], ie. tbl(db_con, user_table), that connects to the user table 
#' that corresponds to the standard data model table.
#' 
user_table <- function(table_map, db_con, desired_cdm_table) {
  tryCatch({
  table_name <- table_map$model_match[[1]] %>% 
    filter(.data$table == desired_cdm_table) %>% 
    distinct(.data$table, .keep_all = T) %>% 
    pull(.data$user_database_table)
  tbl(src = db_con, table_name)
  },
  error=function(error) {
    dplyr::tibble(missing_table = glue::glue('The {desired_cdm_table} table is not present in the currently connected database.'))
  })
}

#' user_field
#'
#' @inheritParams user_table
#' @param desired_cdm_field A string containing the field name in the desired CDM.
#' 
#' @keywords internal
#' 
#' @importFrom magrittr %>% 
#' @importFrom dplyr select filter pull
#' @importFrom rlang .data
#' @importFrom tidyr replace_na
#' 
#' @return A string containing the user database field pertaining to the standard data model field
#' 
user_field <- function(table_map, desired_cdm_table, desired_cdm_field){
  table_map$model_match[[1]] %>% 
    filter(.data$table == desired_cdm_table & .data$field == desired_cdm_field) %>% 
    mutate(user_fields = tidyr::replace_na(.data$user_fields, 'missing_table')) %>% 
    pull(.data$user_fields)
}

# Datasets ----
#' Supported Data Model Schemas
#'
#' A dataset containing data model information along with the corresponding
#' version and nested schema information.
#' 
#' @docType data
#'
#' @format A data frame with 12 rows and 4 variables:
#' \describe{
#'   \item{data_model}{Data model name}
#'   \item{model_version}{Version of the data model}
#'   \item{data}{Nested database schemas, including included table and field mappings}
#'   \item{file_path}{Where schema was imported from}
#'   ...
#' }
#' @source \url{https://github.com/OHDSI/CommonDataModel/}
#' @source \url{https://github.com/MIT-LCP/mimic-code}
"supported_data_models"

# Module Documentation ----
#' Data Model Detection Module
#'
#' @description 
#' 
#' This module will interrogate a user connected database, comparing it with 
#' known common data models to determine the both the data model and version 
#' (when applicable) of the user's database.
#' 
#' It informs the rest of the application how to interpret and display the data
#' stored in the connected database, when possible. If an unsupported data model 
#' is detected, the user is informed and given the opportunity to connect to 
#' a different database.
#' 
#' This module consists of the following components:
#' 
#' ## Module UI functions
#' These functions return a Shiny `tagList` containing various UI elements of the 
#' ReviewR application. UI components are calculated by the 
#'  `data_model_detection_server` function of this module.
#' \itemize{
#' \item{`data_model_detection_ui`}: A server defined uiOutput 
#' describing the detected data model and version.
#' \item{`patient_chart_ui`}: The "Patient Chart," with the appropriate display 
#' elements based on the detected data model. Appears on the "Chart Review" tab
#' of ReviewR.
#' }
#' ## Module Server function
#' The server function of this module is responsible for calculating the display 
#' elements included in the UI functions of this module as well as returning a
#' reactiveValues object containing various other objects used by other modules.
#' \itemize{
#' \item{`data_model_detection_server`}: Contains the data model detection logic
#' and calculates UI elements. Returns a reactiveValues object containing variables
#' used in other modules.
#' }
#' 
#' @param id The Module namespace
#' @name mod_data_model_detection
#' 
#' @return 
#' *data_model_detection_ui*:
#' \item{tagList}{A uiOutput describing the detected data model and version.}
#' *patient_chart_ui*:
#' \item{tagList}{The "Patient Chart" on the "Chart Review" tab of ReviewR.}
#' *data_model_detection_server*:
#' \item{reactiveValues}{
#' \itemize{
#' \item{*table_map*}: A tibble containing a mapping between the CDM standard
#' tables and fields to the user connected tables and fields.
#' \item{*message*}: A character vector containing the message describing the 
#' detected data model and version. 
#' \item{*table_functions*}: A tibble containing the table function names for 
#' the detected data model as well as the table names which the functions will
#' create.
#' \item{*all_patients_table*}: A tibble containing *only* the "All Patients"
#' function and table name. Used to render the "All Patients" table on the 
#' "Patient Search" tab.
#' \item{*subject_tables*}: A tibble containing the "Subject Specific" 
#' functions and table names. Used to render the patient chart tabsets on
#' the "Chart Review" tab.
#' }}
#' 
NULL
#> NULL

# UI ----
#' Data Model Detection UI
#' @rdname mod_data_model_detection
#'
#' @keywords internal
#' 
#' @importFrom shiny NS tagList HTML
#' 

data_model_detection_ui <- function(id) {
  ns <- NS(id)
  tagList(
    uiOutput(ns('data_model_ui'))
    )
  }

#' Patient Chart UI
#' @rdname mod_data_model_detection
#' 
#' @keywords internal
#' 

patient_chart_ui <- function(id) {
  ns <- NS(id)
  tagList(
    div(
      shinyWidgets::searchInput(inputId = ns('global_search'), 
                                placeholder = 'Search string or regex',
                                btnSearch = icon("search"), 
                                btnReset = icon("remove"),
                                value = '',
                                resetValue = '',
                                width = '400px'),
      style = 'float: right;'
      ),
    uiOutput(ns('patient_chart'))
    )
  }

# Server ----
#' @rdname mod_data_model_detection
#' @param database_vars A reactiveValues object as returned by \link[ReviewR]{mod_database_setup}.
#' @param navigation_vars A reactiveValues object as returned by \link[ReviewR]{mod_navigation}.
#' @param parent_session The session information from the parent environment of this module.
#'  
#' @keywords internal
#' 
#' @importFrom magrittr %>% 
#' @importFrom DBI dbListTables dbListFields 
#' @importFrom dplyr mutate rename select left_join filter ungroup arrange slice group_by desc
#' @importFrom DT dataTableProxy updateSearch
#' @importFrom glue glue
#' @importFrom purrr map map2 iwalk imap
#' @importFrom stringr str_detect str_replace str_replace_all regex str_extract
#' @importFrom tidyr unnest as_tibble separate drop_na
#' @importFrom rlang .data
#' @importFrom snakecase to_title_case
#' @importFrom utils data lsf.str

data_model_detection_server <- function(id, database_vars, navigation_vars, parent_session) {
  moduleServer(
    id,
    function(input, output, session) {
      ns <- session$ns
      data_model_vars <- reactiveValues(
        table_map = NULL,
        message = NULL,
        table_functions = NULL,
        all_patients_table = NULL, 
        subject_tables = NULL
        )
      patient_table_vars <- reactiveValues(
        table_map = NULL,
        db_connection = NULL,
        subject_id = NULL
        )
      
      # Calculate Table Map ----
      ## Determine which user fields map to known CDM field values
      observeEvent(database_vars()$is_connected, {
        req(database_vars()$is_connected)
        if(is.null(database_vars()$db_con)) {
          data_model_vars$table_map <- dplyr::tibble(.rows = 0)
        } else {
          ### Load user tables and nest fields. 
          user_tables <-  dplyr::tibble(user_database_table = dbListTables(database_vars()$db_con)) %>% 
            mutate(user_fields_long = map(.x = .data$user_database_table,.f = dbListFields,conn=database_vars()$db_con),
                   user_fields_long = map(.x = .data$user_fields_long,.f = as_tibble)
                   ) %>% 
            #### Unnest user tables and coerce to match cdm standards
            unnest(cols = c(.data$user_fields_long)) %>% 
            rename(user_fields = .data$value) %>% 
            mutate(clean_user_fields = tolower(.data$user_fields),
                   clean_user_fields = str_replace(string = .data$clean_user_fields, pattern = regex(pattern = '[.!?\\-]'),replacement = '_'),
                   clean_table = tolower(.data$user_database_table),
                   clean_table = str_replace(string = .data$clean_table, pattern = regex(pattern = '[.!?\\-]'),replacement = '_')) %>% 
            select(.data$user_database_table, .data$clean_table, .data$user_fields, .data$clean_user_fields)
          
          ### Join user tables with supported data models, determine which one the user is likely running
          user_joined <- ReviewR::supported_data_models %>% 
            mutate(model_match = map(.x = data,.f = left_join, user_tables, by = c('joinable_table'='clean_table', 'joinable_field'='clean_user_fields'))) %>% 
            mutate(filtered = map(.x = .data$model_match,.f = filter, is.na(.data$user_fields)!=T),
                   count_filtered = map(.x = .data$filtered,.f = nrow), 
                   count_filtered = unlist(.data$count_filtered)
                   )
          
          ### Select and store the most likely mapping based on matching fields
          data_model_vars$table_map <- user_joined %>% 
            ungroup() %>% 
            filter(.data$count_filtered == max(.data$count_filtered)) %>% 
            select(.data$data_model, .data$model_version, .data$data, .data$model_match, .data$count_filtered) %>%
            arrange(desc(.data$model_version)) %>%
            slice(1) %>% 
            filter(.data$count_filtered > 0)
          }
        })
      
      # Store Additional Vars ----
      observeEvent(data_model_vars$table_map, ignoreInit = T, {
        req(data_model_vars$table_map)
        ## Data Model Message
        data_model_vars$message <-if (nrow(data_model_vars$table_map) > 0) {
            HTML(glue::glue('<em>Data Model: {data_model_vars$table_map$data_model} {data_model_vars$table_map$model_version}</em>'))
            } else {HTML(paste("<font color='#e83a2f'><em>The connected database does not appear to contain a supported data_model. Please disconnect and select another database.</em></font>"))
            }
        ## Data Model Table Functions
        if (nrow(data_model_vars$table_map) > 0) {
          ## Attach ReviewR namespace (if not already attached) so that lsf.str can find database table functions
          if(any(str_detect(string = search(), pattern = 'package:ReviewR') ) == FALSE) {
            attachNamespace("ReviewR")
            }
          data_model_vars$table_functions <- lsf.str(envir = asNamespace('ReviewR'), pattern = glue::glue('{data_model_vars$table_map$data_model}_table')) %>% 
            as.character() %>% 
            dplyr::tibble(function_name = .) %>% 
            # filter(stringr::str_detect(.data$function_name, glue::glue('{data_model_vars$table_map$data_model}_table') )) %>% 
            mutate(table_name = stringr::str_remove(.data$function_name, glue::glue('{data_model_vars$table_map$data_model}_table_') ))
          data_model_vars$all_patients_table <- data_model_vars$table_functions %>% 
            filter(.data$table_name == 'all_patients')
          data_model_vars$subject_tables <- data_model_vars$table_functions %>% 
            filter(.data$table_name != 'all_patients')
          ## Create Arguments for database table functions
          patient_table_vars$table_map = data_model_vars$table_map
          patient_table_vars$db_connection = database_vars()$db_con
          } else { 
            data_model_vars$table_functions <- NULL 
            data_model_vars$all_patients_table <- NULL
            data_model_vars$subject_tables <- NULL
            patient_table_vars$table_map <- NULL
            patient_table_vars$db_connection <- NULL
            patient_table_vars$subject_id <- NULL}
        })
      
      # Data Model UI ----
      ## Create a UI output do display the detected data model 
      output$data_model_ui <- renderUI({
        req(database_vars()$is_connected == 'yes')
        tagList(
          data_model_vars$message
          )
        })
      
      # Dynamic Patient Chart ----
      ## Add Subject ID to patient_table_vars reactiveValues object
      observeEvent(navigation_vars$selected_subject_id, {
        req(navigation_vars$selected_subject_id)
        patient_table_vars$subject_id <- navigation_vars$selected_subject_id
        })
      
      ## Dynamically create reactive expressions for all patient table functions for detected data model
      patient_tables <- reactive({
        req(data_model_vars$subject_tables$function_name)
        map(data_model_vars$subject_tables$function_name,
            ~reactive({
              req(patient_table_vars$subject_id)
              rlang::exec(.x, !!!reactiveValuesToList(patient_table_vars))
              })
            )
        })
      
      ## Initialize DT Proxy reactiveValues
      proxy_vars <- reactiveValues()
      
      ## Dynamically create DT::datatable outputs, for every patient table reactive expression
      ## Big Thanks: https://tbradley1013.github.io/2018/08/10/create-a-dynamic-number-of-ui-elements-in-shiny-with-purrr/
      observeEvent(patient_tables(), {
        purrr::iwalk(patient_tables(), ~{
          ## Create DT Outputs
          output_name <- glue::glue('dt_{.y}')
          output[[output_name]] <- DT::renderDataTable({
            rlang::exec(.x) %>% reviewr_datatable(dom = 'ti', search_term = input$global_search)
            })
          ## Create Matching DT Proxies
          proxy_name <- glue::glue('dt_proxy_{.y}')
          proxy_vars[[proxy_name]] <- DT::dataTableProxy(outputId = ns(output_name), session = parent_session)
          })
        })

      # Patient Chart UI ----
      ## Create a tabsetPanel, consisting of DT::datatable outputs
      output$patient_chart <- renderUI({
        req(patient_tables())
        data_model_vars$tabset_panels <- data_model_vars$subject_tables %>%
          mutate(tab_name = snakecase::to_title_case(.data$table_name),
                 dt_list = imap(patient_tables(), ~{
                   tagList(
                     DT::DTOutput(outputId = ns(glue::glue('dt_{.y}') )) %>% withSpinner(type = 6, proxy.height = '760px')
                   )
                 }),
                 tab_panels = purrr::map2(
                   .data$tab_name,
                   .data$dt_list,
                   ~tabPanel(title = .x, .y)
                   )
                 ) %>%
          pull(.data$tab_panels)
        do.call(tabsetPanel, data_model_vars$tabset_panels)
        })
      
      # Global Search ----
      # observeEvent(input$global_search, {
      #   ## Update DT Proxies with Global Search Term
      #   ### A Proxy Exists for each patient table, use index map to programmatically isolate and update the all available dt proxies
      #   purrr::imap(patient_tables(), ~{
      #             proxy_name <- glue::glue('dt_proxy_{.y}')
      #             DT::updateSearch(proxy = proxy_vars[[proxy_name]], keywords = list(global = input$global_search, columns = NULL))
      #             })
      #   })
      
      # Return ----
      return(data_model_vars)
      }
    )
}