R/scanCoefServer.R

In byandell/qtl2shiny: Shiny interface for 'qtl2' Fine Mapping

#' Shiny coefficient analysis and plot module
#'
#' Shiny module for scan1 LOD and coefficient plots, with interfaces \code{scanCoefUI} and  \code{scanCoefOutput}.
#'
#' @param id identifier for shiny reactive
#' @param job_par,win_par,phe_mx,cov_df,probs_obj,K_chr,analyses_df,project_info,allele_info reactive arguments
#'
#' @author Brian S Yandell, \email{brian.yandell@@wisc.edu}
#' @keywords utilities
#' 
#' @return No return value; called for side effects.
#'
#' @export
#' @importFrom qtl2mediate scan1covar
#' @importFrom ggplot2 autoplot
#' @importFrom DT dataTableOutput renderDataTable
#' @importFrom shiny checkboxInput column downloadButton downloadHandler
#'             fluidRow isTruthy moduleServer NS plotOutput radioButtons
#'             reactive renderPlot renderUI req selectInput setProgress
#'             sliderInput strong tagList uiOutput updateSliderInput
#'             withProgress
#' @importFrom utils write.csv
#' @importFrom grDevices dev.off pdf
#' @importFrom qtl2mediate scan1covar
scanCoefServer <- function(id, job_par, win_par, phe_mx, cov_df, probs_obj, K_chr,
                          analyses_df, project_info, allele_info) {
  shiny::moduleServer(id, function(input, output, session) {
    ns <- session$ns
    
    ## Genome scan 
    scan_obj <- shiny::reactive({
      shiny::req(phe_mx(), probs_obj(), K_chr(), cov_df(), win_par$window_Mbp,
                 job_par$sex_type)
      shiny::withProgress(message = "Genome Scan ...", value = 0, {
        shiny::setProgress(1)
        qtl2mediate::scan1covar(phe_mx(), cov_df(), probs_obj()$probs, K_chr(), analyses_df(),
                                sex_type = job_par$sex_type)
      })
    })
    
    # Scan Window slider
    output$scan_window_input <- shiny::renderUI({
      shiny::req(project_info(), phe_mx(), win_par$window_Mbp)
      chr_id <- shiny::req(win_par$chr_id)
      map <- shiny::req(probs_obj())$map[[chr_id]]
      rng <- round(2 * range(map)) / 2
      selected <- select_range(input$scan_window, rng)
      
      shiny::sliderInput(ns("scan_window"), NULL, rng[1], rng[2],
                         selected, step=.5)
    })
    ## Reset scan_window if chromosome changes.
    observeEvent(probs_obj()$map, {
      map <- shiny::req(probs_obj()$map)
      chr <- shiny::req(win_par$chr_id)
      rng <- round(2 * range(map[[chr]])) / 2
      shiny::updateSliderInput(session, "scan_window", NULL, rng, 
                               rng[1], rng[2], step=.5)
    })
    
    ## Select phenotype for plots.
    output$pheno_name_input <- shiny::renderUI({
      shiny::req(phe_mx())
      shiny::selectInput(ns("pheno_name"), NULL,
                         choices = colnames(phe_mx()))
    })
    
    ## Scan1 plot
    output$scanPlot <- shiny::renderPlot({
      if(!shiny::isTruthy(win_par$chr_id) || !shiny::isTruthy(phe_mx()))
        return(plot_null("need to select\nRegion & Phenotype"))
      shiny::req(win_par$chr_id, input$scan_window, scan_obj(), probs_obj())
      shiny::withProgress(message = 'Genome LOD Plot ...', value = 0, {
        shiny::setProgress(1)
        plot_scan(scan_obj(), 
                  probs_obj()$map, 
                  seq(ncol(scan_obj())), 
                  win_par$chr_id, 
                  input$scan_window, 
                  phe_mx())
      })
    })
    
    ## Coefficient Effects.
    eff_obj <- shiny::reactive({
      shiny::req(phe_mx(), probs_obj(), K_chr(), cov_df(),
                 job_par$sex_type)
      shiny::withProgress(message = 'Effect scans ...', value = 0, {
        shiny::setProgress(1)
        scan1_effect(probs_obj()$probs, phe_mx(), K_chr(), cov_df(),
                     job_par$sex_type, input$blups)
      })
    })
    output$effPlot <- shiny::renderPlot({
      shiny::req(input$pheno_name, scan_obj(), eff_obj(), win_par$chr_id, allele_info())
      map <- shiny::req(probs_obj())$map
      shiny::withProgress(message = 'Effect plots ...', value = 0, {
        shiny::setProgress(1)
        plot_eff(input$pheno_name, eff_obj(), map, scan_obj(), 
                 input$scan_window,, allele_info())
      })
    })
    output$effSummary <- DT::renderDataTable({
      shiny::req(eff_obj(), scan_obj(), probs_obj())
      shiny::withProgress(message = 'Effect summary ...', value = 0, {
        shiny::setProgress(1)
        summary(eff_obj(), scan_obj(), probs_obj()$map)
      })
    }, escape = FALSE,
    options = list(scrollX = TRUE, pageLength = 5))
    
    ## Effect and LOD Plot
    output$lod_effPlot <- shiny::renderPlot({
      shiny::req(input$pheno_name, input$scan_window, win_par$chr_id,
                 eff_obj(), scan_obj(), allele_info())
      map <- shiny::req(probs_obj())$map
      shiny::withProgress(message = 'Effect & LOD plots ...', value = 0, {
        shiny::setProgress(1)
        plot_eff(input$pheno_name, eff_obj(), map, scan_obj(), input$scan_window,
                 addlod = TRUE, allele_info())
      })
    })
    
    output$pheno_choice <- shiny::renderUI({
      switch(shiny::req(input$button),
             "LOD & Effects" =,
             Effects = shiny::uiOutput(ns("pheno_name_input")))
    })
    output$win_choice <- shiny::renderUI({
      switch(shiny::req(input$button),
             LOD     =,
             "LOD & Effects" =,
             Effects = shiny::uiOutput(ns("scan_window_input")))
    })
    output$LOD <- shiny::renderUI({
      switch(shiny::req(input$button),
             LOD             = shiny::plotOutput(ns("scanPlot")))
    })
    output$Effects <- shiny::renderUI({
      switch(shiny::req(input$button),
             Effects         = shiny::plotOutput(ns("effPlot")),
             "LOD & Effects" = shiny::plotOutput(ns("lod_effPlot")))
    })
    output$Summary <- shiny::renderUI({
      switch(shiny::req(input$button),
             Summary = DT::dataTableOutput(ns("effSummary")))
    })
    
    ## Downloads.
    output$downloadData <- shiny::downloadHandler(
      filename = function() {
        file.path(paste0("sum_effects_", win_par$chr_id, ".csv")) },
      content = function(file) {
        shiny::req(eff_obj(), scan_obj(), probs_obj())
        utils::write.csv(summary(eff_obj(), scan_obj(), probs_obj()$map), file)
      }
    )
    output$downloadPlot <- shiny::downloadHandler(
      filename = function() {
        file.path(paste0("scan_", win_par$chr_id, ".pdf")) },
      content = function(file) {
        shiny::req(win_par$chr_id, allele_info())
        effs <- shiny::req(eff_obj())
        scans <- shiny::req(scan_obj())
        win <- shiny::req(input$scan_window)
        map <- shiny::req(probs_obj())$map
        grDevices::pdf(file, width=9,height=9)
        print(ggplot2::autoplot(scans, map,
                                lodcolumn = seq_along(names(effs)),
                                chr = win_par$chr_id,
                                xlim = win))
        for(pheno in names(effs)) {
          plot_eff(pheno, effs, map, scans, win,
                   addlod = TRUE, allele_info())
        }
        grDevices::dev.off()
      }
    )
    output$blups_input <- shiny::renderUI({
      shiny::checkboxInput(ns("blups"), "BLUPs?")
    })
    output$button_input <- shiny::renderUI({
      shiny::radioButtons(ns("button"), "",
                          c("LOD","Effects","LOD & Effects","Summary"),
                          input$button)
    })
  })
}
#' @export
#' @rdname scanCoefServer
scanCoefUI <- function(id) {
  ns <- shiny::NS(id)
  shiny::tagList(
    shiny::strong("Genome Scans"),
    shiny::fluidRow(
      shiny::column(6, shiny::uiOutput(ns("button_input"))),
      shiny::column(6, shiny::uiOutput(ns("blups_input")))),
    shiny::uiOutput(ns("pheno_choice")),
    shiny::uiOutput(ns("win_choice")),
    shiny::fluidRow(
      shiny::column(6, shiny::downloadButton(ns("downloadData"), "CSV")),
      shiny::column(6, shiny::downloadButton(ns("downloadPlot"), "Plots"))))
}
#' @export
#' @rdname scanCoefServer
scanCoefOutput <- function(id) {
  ns <- shiny::NS(id)
  shiny::tagList(
    shiny::uiOutput(ns("LOD")),
    shiny::uiOutput(ns("Effects")),
    shiny::uiOutput(ns("Summary")))
}