R/shinyMediate.R

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

#' Shiny coefficient analysis and plot module
#'
#' Shiny module for scan1 coefficient plots, with interfaces \code{shinyMediateUI} and  \code{shinyMediateOutput}.
#'
#' @param id identifier for shiny reactive
#' @param job_par,win_par,patterns,phe_mx,cov_df,probs_obj,K_chr,analyses_df,pmap_obj,covar,analyses_tbl,peaks,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 qtl2 find_marker scan1
#' @importFrom qtl2mediate comediator_region comediator_type expr_region mediation_test_qtl2
#' @importFrom ggplot2 autoplot
#' @importFrom shiny moduleServer NS reactive req isTruthy
#'   radioButtons selectInput sliderInput updateSliderInput
#'   dataTableOutput plotOutput uiOutput
#'   renderDataTable renderPlot renderUI
#'   fluidRow column strong tagList
#'   withProgress setProgress
#'   downloadButton downloadHandler
#' @importFrom plotly renderPlotly plotlyOutput
#' @importFrom dplyr filter
#' @importFrom utils write.csv
#' @importFrom grDevices dev.off pdf
#' @importFrom rlang .data
#' 
shinyMediate <- function(id, job_par, win_par, patterns, phe_mx, cov_df, probs_obj, K_chr,
                         analyses_df, pmap_obj, covar, analyses_tbl, peaks,
                         project_info, allele_info) {
  shiny::moduleServer(id, function(input, output, session) {
  ns <- session$ns
  
  chr_id <- reactive({
    shiny::req(win_par$chr_id)
  })
  scan_window <- reactive({
    shiny::req(win_par)
    win_par$peak_Mbp + c(-1,1) * win_par$window_Mbp
  })
  ## Expression data
  expr_ls <- reactive({
    shiny::req(win_par)
    qtl2mediate::expr_region(chr_id(), scan_window(), covar(),
                             shiny::req(pmap_obj()), 
                    drivers = shiny::req(input$qtls),
                    query_mrna = query_mrna())
  })
  query_mrna <- reactive({
    read_query_rds(project_info(), "query_mrna.rds")
  })
  pheno_data <- reactive({
    pheno_read(project_info(), analyses_tbl())
  })
  
  ## Comediator data
  comed_ls <- reactive({
    shiny::req(input$pheno_name, win_par, project_info())
    qtl2mediate::comediator_region(input$pheno_name, chr_id(), scan_window(), 
                      covar(), analyses_tbl(), peaks(), 
                      shiny::req(input$qtls), shiny::req(pmap_obj()),
                      pheno_data())
  })
  med_ls <- reactive({
    out <- switch(shiny::req(input$med_type, input$pheno_name),
           expression = expr_ls(),
           phenotype = qtl2mediate::comediator_type(comed_ls(), shiny::req(peaks()),
                                       input$pheno_name,
                                       shiny::isTruthy(input$other)))
    out
  })
  
  # Get genotype matrix and map at 
  peak_mar <- reactive({
    qtl2::find_marker(probs_obj()$map, chr_id(), input$pos_Mbp)
  })
  geno_max <- reactive({
    shiny::req(input$pos_Mbp, probs_obj())
    subset(probs_obj()$probs, chr = chr_id(), mar = peak_mar())[[1]][,,1]
  })
  
  # Select pattern 
  sdps <- shiny::reactive({
    shiny::req(patterns(), input$pheno_name)
    unique(dplyr::filter(patterns(), .data$pheno == input$pheno_name)$sdp)
  })
  haplos <- reactive({
    shiny::req(allele_info())$code
  })
  choices_pattern <- reactive({
    shiny::req(sdps(), haplos())
    qtl2pattern::sdp_to_pattern(sdps(), haplos())
  })
  output$pattern <- shiny::renderUI({
    # This does not quite work right.
    choices <- choices_pattern()
    selected <- input$pattern
    if(is.null(selected)) {
      selected <- choices[1]
    }
    if(!(selected %in% choices)) {
      selected <- choices[1]
    }
    shiny::selectInput(ns("pattern"), NULL,
                       choices = choices, selected)
  })
  sdp <- reactive({
    shiny::req(input$pattern)
    choices <- choices_pattern()
    sdps()[match(input$pattern, choices, nomatch = 1)]
  })
  
  ## Triad Plots
  shinyTriad("triad", input, patterns, geno_max, peak_mar, med_ls, mediate_signif,
             phe1_mx, cov_df, K_chr, probs_obj, chr_id, sdp)

  ## Mediate1
  probs_chr <- reactive({
    probs_obj()$probs[[chr_id()]]
  })
  mediate_obj <- shiny::reactive({
    shiny::req(phe1_mx(), probs_obj(), K_chr(), cov_df(), geno_max(), 
               input$pos_Mbp, input$med_type, med_ls())
    shiny::withProgress(message = "Mediation Scan ...", value = 0, {
      shiny::setProgress(1)
      qtl2mediate::mediation_test_qtl2(
        target = phe1_mx(),
        mediator = med_ls()[[1]],
        annotation = med_ls()[[2]],
        covar_tar = cov_df(),
        covar_med = med_ls()$covar,
        genoprobs = probs_obj()$probs,
        map = probs_obj()$map,
        chr = chr_id(),
        pos = input$pos_Mbp,
        kinship = K_chr())
    })
  })
  mediate_signif <- shiny::reactive({
    out <- shiny::req(mediate_obj())
    out$best <- dplyr::filter(out$best, .data$pvalue <= 0.1)
    class(out) <- class(mediate_obj())
    out
  })

  phe1_mx <- reactive({
    shiny::req(phe_mx())
    phename <- shiny::req(input$pheno_name)
    if(phename %in% colnames(phe_mx())) {
      phe_mx()[, phename, drop = FALSE]
    } else {
      NULL
    }
  })
  ## Select phenotype for plots.
  output$pheno_name <- shiny::renderUI({
    shiny::req(phe_mx())
    shiny::selectInput(ns("pheno_name"), NULL,
                choices = colnames(phe_mx()),
                selected = input$pheno_name)
  })
  ## Select plot format.
  output$med_plot <- shiny::renderUI({
    shiny::selectInput(ns("med_plot"), NULL,
                       choices = c("Position by LR", 
                                   "Position by P-value", 
                                   "P-value by LR",
                                   "Allele Effects",
                                   "Mediator Effects"),
                       selected = input$med_plot)
  })
  ## Select type of mediation.
  output$med_type <- shiny::renderUI({
    shiny::selectInput(ns("med_type"), NULL,
                       choices = c("phenotype","expression"),
                       selected = input$med_type)
  })
  
  med_plot_type <- reactive({
    switch(shiny::req(input$med_plot),
           "Position by LR" = "pos_LR",
           "Position by P-value" = "pos_pvalue",
           "P-value by LR" = "pvalue_LR",
           "Allele Effects" = "alleles",
           "Mediator Effects" = "mediator")
  })
  ## Mediate1 plot
  output$medPlot <- shiny::renderPlot({
    if(!shiny::isTruthy(med_ls()) || !shiny::isTruthy(mediate_obj())) {
      plot_null("too much\nmissing data\nin mediators\nreduce window width")
    } else {
      shiny::req(med_plot_type(), mediate_obj())
      shiny::withProgress(message = 'Mediation Plot ...', value = 0, {
        shiny::setProgress(1)
        ggplot2::autoplot(
          mediate_obj(), med_plot_type(),
          local_only = input$local, 
          significant = input$signif) +
          ggplot2::geom_point(size = 4)
      })
    }
  })
  ## Mediate1 plotly
  output$medPlotly <- plotly::renderPlotly({
    shiny::req(mediate_obj())
    shiny::withProgress(message = 'Mediation Plotly ...', value = 0, {
      shiny::setProgress(1)
      ggplot2::autoplot(
        mediate_signif(), med_plot_type(),
        local_only = input$local, 
        significant = TRUE)
    })
  })

  output$medSummary <- shiny::renderDataTable({
    shiny::req(mediate_obj())$best
  }, escape = FALSE,
  options = list(scrollX = TRUE, pageLength = 5))

  # Scan Window slider
  output$pos_Mbp <- shiny::renderUI({
    map <- shiny::req(probs_obj())$map[[chr_id()]]
    rng <- round(2 * range(map)) / 2
    if(is.null(selected <- input$pos_Mbp))
      selected <- req(win_par$peak_Mbp)
    shiny::sliderInput(ns("pos_Mbp"), NULL, rng[1], rng[2],
                       selected, step=.1)
  })
  ## Reset pos_Mbp if chromosome changes.
  observeEvent(chr_id(), {
    map <- shiny::req(probs_obj()$map)
    rng <- round(2 * range(map[[chr_id()]])) / 2
    shiny::updateSliderInput(session, "pos_Mbp", NULL, 
                             req(win_par$peak_Mbp), 
                             rng[1], rng[2], step=.1)
  })

  output$out_choice <- shiny::renderUI({
    switch(shiny::req(input$button),
           Static      = shiny::plotOutput(ns("medPlot")),
           Interactive = plotly::plotlyOutput(ns("medPlotly")))
  })
  output$qtls <- shiny::renderUI({
    if(is.null(selected <- input$qtls))
      selected <- 2
    shiny::radioButtons(ns("qtls"), "",
                        c("1 QTL" = 1, "2 QTLs" = 2),
                        selected, inline = TRUE)
  })
  output$radio <- shiny::renderUI({
    shiny::radioButtons(ns("button"), "",
                        c("Static","Interactive"),
                        "Static")
  })
  output$checkplot <- shiny::renderUI({
    shiny::checkboxInput(ns("checkplot"), "Triad Plot", input$checkplot)
  })
  output$local_other <- shiny::renderUI({
    switch(shiny::req(input$med_type),
           expression = shiny::checkboxInput(ns("local"), "Local?", input$local),
           phenotype  = shiny::checkboxInput(ns("other"), "Other types?", input$other))
  })
  output$signif <- shiny::renderUI({
    if(shiny::isTruthy(input$signif)) {
      value <- input$signif
    } else {
      value <- TRUE
    }
    shiny::checkboxInput(ns("signif"), "Significant?", value)
  })

  ## Downloads.
  output$downloadData <- shiny::downloadHandler(
    filename = function() {
      file.path(paste0("mediate_", chr_id(), "_", win_par$peak_Mbp, ".csv")) },
    content = function(file) {
      shiny::req(mediate_obj())
      utils::write.csv(mediate_obj()$best, file)
    }
  )
  output$downloadPlot <- shiny::downloadHandler(
    filename = function() {
      file.path(paste0("mediate_", chr_id(), "_", win_par$peak_Mbp, ".pdf")) },
    content = function(file) {
      shiny::req(phe_mx(), geno_max(), K_chr(), cov_df(),
                 input$pos_Mbp, input$med_type)
      grDevices::pdf(file, width=9,height=9)
      for(pheno in colnames(phe_mx())) {
        med <- qtl2mediate::mediation_test_qtl2(
          target = phe_mx()[, pheno, drop = FALSE],
          mediator = med_ls()[[1]],
          annotation = med_ls()[[2]],
          covar_tar = cov_df(),
          covar_med = med_ls()$covar,
          genoprobs = probs_obj()$probs,
          map = probs_obj()$map,
          chr = chr_id(),
          pos = input$pos_Mbp,
          kinship = K_chr())
        
        print(ggplot2::autoplot(
          med, "pos_LR",
          local_only = input$local, 
          significant = input$signif))
        print(ggplot2::autoplot(
          med, "pos_pvalue",
          local_only = input$local, 
          significant = TRUE))
        print(ggplot2::autoplot(
          med, "pvalue_LR",
          local_only = input$local, 
          significant = TRUE))
        print(ggplot2::autoplot(
          med, "mediator",
          local_only = input$local, 
          significant = TRUE))
      }
      grDevices::dev.off()
    })
  output$mediation <- renderUI({
    shiny::tagList(
      shiny::uiOutput(ns("qtls")),
      shiny::uiOutput(ns("radio")),
      shiny::uiOutput(ns("pheno_name")),
      shiny::uiOutput(ns("med_type")),
      shiny::fluidRow(
        shiny::column(6, shiny::uiOutput(ns("signif"))),
        shiny::column(6, shiny::uiOutput(ns("local_other")))),
      shiny::uiOutput(ns("med_plot")),
      shiny::uiOutput(ns("pos_Mbp")),
      shiny::fluidRow(
        shiny::column(6, shiny::downloadButton(ns("downloadData"), "CSV")),
        shiny::column(6, shiny::downloadButton(ns("downloadPlot"), "Plots"))))
  })
  output$medUI <- shiny::renderUI({
    switch(1 + shiny::isTruthy(input$checkplot),
           {
             shiny::uiOutput(ns("mediation"))
           },
           {
             shiny::tagList(
               shiny::uiOutput(ns("pattern")), # Works sort of. 
               shinyTriadUI(ns("triad")))
           })
  })
  output$medOutput <- shiny::renderUI({
    if(shiny::isTruthy(input$checkplot))
      shinyTriadOutput(ns("triad"))
    else
      shiny::tagList(
        shiny::uiOutput(ns("out_choice")),
        shiny::dataTableOutput(ns("medSummary")))
  })
})
}
shinyMediateUI <- function(id) {
  ns <- shiny::NS(id)
  shiny::tagList(
    shiny::strong("Mediation"),
    shiny::uiOutput(ns("checkplot")),
    shiny::uiOutput(ns("medUI")))
}
shinyMediateOutput <- function(id) {
  ns <- shiny::NS(id)
  shiny::uiOutput(ns("medOutput"))
}