R/esr_mlst_data.R

In pydupont/esr.shiny.redcap.modules: ESR shiny reporting apps linked to RedCap

source("R/global.R")
#' The data loaded from redcap contain the metadata, qc data and mlst data.
#' This function separate the data. It returns a `reactiveValues` witht the
#' slots:
#' \describe{
#' \item{metadata_cols}: The list of the columns belonging to the metadata
#' \item{mlst_cols}: The list of the columns belonging to the mlst
#' \item{qc_cols}: The list of the columns belonging to the qc
#' \item{metadata}: The metadata data frame
#' \item{mlst}: The mlst data frame
#' \item{qc}: The QC data frame
#' }
#' This function needs global variables (defined in `global.R`):
#' \describe{
#' \item{record_id_cols}: a character list of all the identifier columns (or any
#' column) to keep in all three datasets
#' \item{mlst_starts}: a string defined as the begining of the name of all the
#' columns to include in the mlst table only
#' \item{qc_columns}: a list of columns to inlude in the qc dataset only
#' }
#'
#' @param dataset: the dataset as loaded from the redcap database
#'
#' @return a `reactiveValues` of the result (details in the function
#'   description)
#'
#' @export
split_mlst_and_metadata <- function(dataset){
  result <- reactiveValues()
  ret <- reactive({
    dt <- dataset()
    if(is.null(dt)){
      js$disableTab(tab_names$metadata)
      log_debug("split_mlst_and_metadata: dt is NULL")
      result$mlst <- NULL
      result$metadata <- NULL
    } else{
      log_debug("split_mlst_and_metadata: dt is not NULL")
      record_id_cols <- names(dt)[names(dt) %in% record_id_cols]
      mlst_cols <- names(dt)[str_starts(names(dt), mlst_starts)]
      metadata_cols <- names(dt)[!names(dt) %in% c(mlst_cols, qc_columns)]
      result$metadata_cols <- metadata_cols
      result$mlst_cols <- mlst_cols
      result$mlst <- reduce_mlst_matrix(dt %>% select(one_of(c(record_id_cols, mlst_cols))))
      result$qc_data <- dt %>% select(one_of(c(main_record_idt_col, qc_columns))) %>%
        type_convert(col_types = NULL, na = c("", "NA", "?"), trim_ws = TRUE)
      result$metadata <- dt %>% select(one_of(c(record_id_cols, metadata_cols))) %>%
        type_convert(col_types = NULL, na = c("", "NA", "?"), trim_ws = TRUE)
    }
    return(result)
  })
  return(ret)
}


#' Keeps rows where the number of samples without missings
#' `>= mlst_sample_threshold` (defined in `gloabl.R`) and where the number of
#' missing per allele `>= mlst_allele_threshold`
#'
#' @param mlst data.frame containing the mlst data
#'
#' @return the modified mlst data.frame
#'
#' @noRd
reduce_mlst_matrix <- function(mlst){
  M <- mlst[,str_starts(names(mlst), mlst_starts)] %>%
    type_convert(col_types = NULL, na = c("", "NA", "?"), trim_ws = TRUE)
  row.names(M) <- mlst$record_id

  M[M <= 0] <-  NA

  cols_to_keep <- ((nrow(M) - colSums(is.na(M))) / nrow(M) >= mlst_allele_threshold)
  M <- M[,cols_to_keep]
  rows_to_keep <- ((ncol(M) - rowSums(is.na(M))) / ncol(M) > mlst_sample_threshold)
  mlst <- mlst[rows_to_keep,]
  cols_to_keep <- ((nrow(mlst) - colSums(is.na(mlst))) / nrow(mlst) > mlst_allele_threshold)
  mlst <- mlst[,cols_to_keep]

  M$record_id <- row.names(M)
  mlst <- mlst[,!str_starts(names(mlst), mlst_starts)] %>%
    left_join(M, by="record_id")
  return(mlst)
}

#' The function shiny module ui defining the ui representing the metadata table
#' block
#'
#' @param id: the name of the namesapce
#'
#' @export
metadata_ui <- function(id){
  ns <- NS(id)
  tagList(
    div(actionButton(ns("selectall"), label="Select/Deselect all"),class="row metadata_button"),
    div(
      dataTableOutput(ns("metadata_table")) %>% withSpinner(type=spinner_type),
      class="row metadata_table"
    ),
    div(
      div(
        actionButton(ns("selectall2"), label="Select/Deselect all"),
        # checkboxInput(ns("download_with_mlst_check"), "Download including MLST data", value = F),
        downloadButton(ns("table_download"), "Download CSV"),
        class = "col-sm-4"),
      class="row metadata_button"
    )
  )
}

#' Shiny module computing loading the metadata in its table. Also contains the
#' logic to (de)select all and download. The data to represent is one of the
#' parameters of the module. This is to avoid to link the function
#' `split_mlst_and_metadata` with this module in order to allow the user to
#' modify the metadata to load (eg. to set data types)
#'
#' @param input,output,session standard \code{shiny} boilerplate
#' @param data the dataset to load. Should have been found using the function
#'   `split_mlst_and_metadata`.
#'
#' @export
redcap_load_metadata_module <- function(input, output, session, data){

  dt_proxy_metadata <- DT::dataTableProxy("metadata_table", session = session)

  rvalues <- reactiveValues(selall = 0)

  shiny::observeEvent(input$selectall, {
    log_debug("redcap_load_metadata_module: click top button")
    rvalues$selall <- rvalues$selall + 1
    log_debug(paste0("redcap_load_metadata_module: ", rvalues$selall))
    if(as.integer(rvalues$selall) %% 2 == 1){
      DT::selectRows(dt_proxy_metadata, selected = input$metadata_table_rows_all)
    }else{
      DT::selectRows(dt_proxy_metadata, selected = list())
    }
  })

  shiny::observeEvent(input$selectall2, {
    log_debug("redcap_load_metadata_module: click bottom button")
    rvalues$selall <- rvalues$selall + 1
    if(as.integer(rvalues$selall) %% 2 == 1){
      DT::selectRows(dt_proxy_metadata, selected = input$metadata_table_rows_all)
    }else{
      DT::selectRows(dt_proxy_metadata, selected = list())
    }
  })

  output$metadata_table <- renderDataTable({
    data() %>% datatable
  })

  data_to_download <- reactive({
    dt <- data()
    if(is.null(dt)){return(data.frame())}
    return(dt)
  })

  output$table_download <- downloadHandler(
    filename="table.csv",
    content = function(myfile) {
      data_to_download() %>%
        write_csv(myfile)
    }
  )

}

#' Allows the user to load private metadata
#'
#' @param data_input_path where were the data saved
#'
#' @return a data frame of the data
#'
#' @export
user_metadata <- function(data_input_path) {
  ret <- reactive({
    p <- data_input_path
    if (is.null(p)) {
      return(NULL)
    }
    df <- read_excel(p)
    if (length(levels(as.factor(df[[names(df)[1]]]))) < nrow(df)) {
      return(NULL)
    }
    return(df)
  })
  return(ret)
}

#' merge the user metadata with the current metadata
#'
#' @param data_input_path where the temporary file with the user data was saved
#' @param redcap_metadata the current set of metadata
#' @param selected_rows the selected rows in the metadata
#'
#' @return the result of the merge as a data frame
#'
#' @export
metadata_with_user_metadata <-
  function(data_input_path,
           redcap_metadata,
           selected_rows) {
    ret <- reactive({
      user_metadata <- user_metadata(data_input_path)()
      # user_metadata <- NULL
      metadata <- redcap_metadata()
      if (!is.null(user_metadata)) {
        join_by <- setNames(colnames(user_metadata)[1], main_record_idt_col)
        metadata <-
          left_join(metadata, user_metadata, by = join_by)
      }
      if (!is.null(selected_rows) &&
          length(selected_rows) >= 2) {
        metadata <- metadata[metadata[[main_record_idt_col]] %in% selected_rows,]
      }
      return(metadata)
    })
    return(ret)
  }