R/esr_qc.R

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

if(file.exists("R/global.R")){source("R/global.R")}
#' UI of the qc module
#'
#' @param id the namespace id
#'
#' @export
qc_ui <- function(id){
  ns <- NS(id)
  tagList(
    dataTableOutput(ns("qc_table")) %>%
      withSpinner(type = spinner_type),
    prettySwitch(
      inputId = ns("show_outliers"),
      label = "Show failed QC",
      value = FALSE,
      fill = TRUE,
      status = "primary"
    ),
    div(
      div(plotOutput(ns("qc_plot_2")) %>% withSpinner(type = spinner_type),
          class = "col-sm-3"),
      div(plotOutput(ns("qc_plot_3")) %>% withSpinner(type = spinner_type),
          class = "col-sm-3"),
      div(plotOutput(ns("qc_plot_4")) %>% withSpinner(type = spinner_type),
          class = "col-sm-3"),
      div(plotOutput(ns("qc_plot_5")) %>% withSpinner(type = spinner_type),
          class = "col-sm-3"),
      class ="row"
    ),
    div(
      div(plotOutput(ns("qc_plot_6")) %>% withSpinner(type = spinner_type),
          class = "col-sm-3"),
      div(plotOutput(ns("qc_plot_7")) %>% withSpinner(type = spinner_type),
          class = "col-sm-3"),
      div(plotOutput(ns("qc_plot_8")) %>% withSpinner(type = spinner_type),
          class = "col-sm-3"),
      div(plotOutput(ns("qc_plot_9")) %>% withSpinner(type = spinner_type),
          class = "col-sm-3"),
      class ="row"
    )
  )
}

#' Guess bad QC samples using the standard R outlier rule as defined in the
#' boxplot. If a sample fails QC more than halk of the time, it is marked as
#' failed QC generally
#'
#' @param data the qc data
#'
#' @return the original qc data with an added column
#'
#' @noRd
guess_bad_qc <- function(data){
  data_qc <- data[,!names(data) %in% c(main_record_idt_col)]
  qc <- data.frame(matrix(ncol = ncol(data_qc), nrow = nrow(data_qc)))
  names(qc) <- names(data_qc)
  for(x in names(data_qc)){
    outliers <- data_qc[[x]] %in% boxplot.stats(data_qc[[x]])$out
    qc[[x]] <- outliers
  }
  data$failed_qc <- rowSums(qc) > ncol(data_qc) %/% 2
  return(data)
}

#' Build QC plot
#'
#' @param data the qc data
#' @param column the column of the qc data for which to build the plot
#' @param selected the selected isolate to highlight in the plot (or NULL)
#' @param include_outliters a boolen saying wether to include the outliers or
#' not
#'
#' @return a gglpot oblect
#'
#' @noRd
plot_qc <- function(data, column, selected, include_outliers){
  col_name <- names(data)[column]
  selection <- data[selected,main_record_idt_col]
  if(length(selection) == 1){selection = c(selection)}
  log_debug(paste0(names(selected)[column], ": ", selection))
  if(!include_outliers){
    data <- data %>% filter(failed_qc == F)
  }
  data$selected <- data[[main_record_idt_col]] %in% selection
  dt <- data %>%
    gather(key="qc_metric", value="value", -c(!!main_record_idt_col, selected, failed_qc)) %>%
    mutate(value = as.numeric(value)) %>%
    filter(qc_metric == col_name)
  p <- ggplot(dt, aes(qc_metric, value)) +
    geom_violin() +
    geom_boxplot(width=0.1) +
    geom_point(data = dt %>% filter(selected == TRUE),
               colour = "green", alpha = 0.8, size = 2) +
    geom_point(data = dt %>% filter(failed_qc == TRUE),
               colour = "red",
               alpha = 0.8, size = 2) +
    ggtitle(col_name) +
    theme(legend.position = "none")
  return(p)
}

#' The QC module
#'
#' @param input,output,session shiny module biolerplate
#' @param qc_data the qc as loaded by `split_mlst_and_metadata` from the
#' `esr_mlst_data` module
#'
#' @export
qc_module <- function(input, output, session, qc_data){
  ret <- reactive({
    # browser()
    data <- qc_data()
    if(! is.null(data)){
      data <- data %>%
        select(one_of(c(main_record_idt_col, qc_columns)))
      if(!is.null(input$table_rows_selected)){
        data <- data[input$table_rows_selected,]
      }
      data <- guess_bad_qc(data)
      return(data)
    }else{
      NULL
    }
  })

  output$qc_table <- renderDataTable(
    datatable(
      ret(),
      selection = 'single',
      options = list(pageLength = 5)
    )
  )

  selected <- reactive({
    if(!is.null(input$qc_table_rows_selected)){
      return(input$qc_table_rows_selected)
    }else{
      return(c())
    }
  })

  output$qc_plot_2 <- renderPlot({
    plot_qc(ret(), column = 2, selected = selected(), input$show_outliers) # avg_quality
  })
  output$qc_plot_3 <- renderPlot({
    plot_qc(ret(), column = 3, selected = selected(), input$show_outliers) # avg_read_coverage
  })
  output$qc_plot_4 <- renderPlot({
    plot_qc(ret(), column = 4, selected = selected(), input$show_outliers) # length
  })
  output$qc_plot_5 <- renderPlot({
    plot_qc(ret(), column = 5, selected = selected(), input$show_outliers) # n50
  })
  output$qc_plot_6 <- renderPlot({
    plot_qc(ret(), column = 6, selected = selected(), input$show_outliers) # nr_contigs
  })
  output$qc_plot_7 <- renderPlot({
    plot_qc(ret(), column = 7, selected = selected(), input$show_outliers) # nr_bases_acgt
  })
  output$qc_plot_8 <- renderPlot({
    plot_qc(ret(), column = 8, selected = selected(), input$show_outliers) # nr_baf_present
  })
  output$qc_plot_9 <- renderPlot({
    plot_qc(ret(), column = 9, selected = selected(), input$show_outliers) # nr_baf_perfect
  })

}