R/shinyProbs.R

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

#' Shiny Probability module
#'
#' Shiny genotype probability access.
#' 
#' @param id identifier for shiny reactive
#' @param win_par,pheno_names,project_info reactive arguments
#'
#' @author Brian S Yandell, \email{brian.yandell@@wisc.edu}
#' @keywords utilities
#' 
#' @return Object of class \code{probs}.
#'
#' @export
#' @importFrom assertthat assert_that
#' @importFrom qtl2mediate get_snpprobs
#' @importFrom shiny reactive req 
#'   withProgress setProgress
shinyProbs <- function(id, win_par, project_info) {
  shiny::moduleServer(id, function(input, output, session) {
  ns <- session$ns

  probs_obj <- shiny::reactive({
    shiny::req(project_info())
    chr_id <- shiny::req(win_par$chr_id)
    shiny::withProgress(message = 'Read probs ...', value = 0, {
      shiny::setProgress(1)
      if(shiny::isTruthy(win_par$local)) {
        mid <- req(win_par$peak_Mbp)
        win <- req(win_par$window_Mbp)
        start_val <- mid - win
        end_val <- mid + win
      } else {
        start_val <- end_val <- NULL
      }

      # Define query_probs function
      query_probs <- read_query_rds(project_info(), "query_probs.rds")
      # Note probs object keeps map with it
      query_probs(chr_id, start_val, end_val)
    })
  })
  
  probs_obj
})
}
#' @rdname shinyProbs
#' @export
shinyPairProbs <- function(id, win_par, project_info) {
  shiny::moduleServer(id, function(input, output, session) {
  ns <- session$ns

  ## Probs object for allele pair diplotypes.
  probs_obj <- shiny::reactive({
    shiny::req(project_info())
    chr_id <- shiny::req(win_par$chr_id)
    range_val <- shiny::req(win_par$peak_Mbp) + 
      c(-1,1) * shiny::req(win_par$window_Mbp)
    shiny::withProgress(message = 'Diplotype Probs ...', value = 0, {
      shiny::setProgress(1)
      
      # Define query_probs function
      query_probs <- read_query_rds(project_info(), "query_probs.rds")
      query_probs(chr_id, range_val[1], range_val[2],
                         allele = FALSE)
    })
  })
  probs_obj
})
}
#' @rdname shinyProbs
#' @export
shinySNPProbs <- function(id, win_par, pheno_names, project_info) {
  shiny::moduleServer(id, function(input, output, session) {
  ns <- session$ns
  
  shiny::reactive({
    shiny::req(project_info())
    shiny::req(chr_id <- win_par$chr_id, 
               peak_Mbp <- win_par$peak_Mbp, 
               window_Mbp <- win_par$window_Mbp)
    shiny::req(pheno_names())
    shiny::withProgress(message = 'SNP Probs ...', value = 0, {
      shiny::setProgress(1)

      # Define query_probs function
      query_probs <- read_query_rds(project_info(), "query_probs.rds")
      probs_obj <- query_probs(chr_id,
                               peak_Mbp - window_Mbp,
                               peak_Mbp + window_Mbp,
                               allele = FALSE)
      
      # define the query_variants function
      query_variants <- read_query_rds(project_info(), "query_variants.rds")
      snpinfo <- query_variants(chr_id,
                                peak_Mbp - window_Mbp,
                                peak_Mbp + window_Mbp)
      qtl2mediate::get_snpprobs(chr_id, peak_Mbp, window_Mbp,
                                pheno_names(), 
                                probs_obj$probs,
                                probs_obj$map,
                                snpinfo)
    })
  })
})
}