R/shinyPeaks.R

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

#' Shiny peaks selection
#'
#' Shiny module for peaks selection, with interfaces \code{shinyPeaksInput}, \code{shinyPeaksUI} and  \code{shinyPeaksOutput}.
#'
#' @param id identifier for shiny reactive
#' @param set_par,pheno_type,peaks_tbl,pmap_obj,project_info reactive arguments
#'
#' @author Brian S Yandell, \email{brian.yandell@@wisc.edu}
#' @keywords utilities
#'
#' @return list of inputs and scan summary
#'
#' @export
#' 
#' @importFrom dplyr distinct filter
#' @importFrom shiny moduleServer NS req 
#'   selectInput sliderInput updateSelectInput updateSliderInput textInput
#'   numericInput updateNumericInput
#'   uiOutput
#'   renderUI
#'   observeEvent
#'   fluidRow column strong tagList
#' @importFrom rlang .data
#'    
shinyPeaks <- function(id, set_par, pheno_type, peaks_tbl, pmap_obj, 
                       project_info) {
  shiny::moduleServer(id, function(input, output, session) {
  ns <- session$ns

  shiny::observeEvent(project_info(), {
    choices <- names(pmap_obj())
    shiny::updateSelectInput(session, "chr_id", shiny::strong("chr"),
                             choices = choices,
                             selected = NULL)
    shiny::updateNumericInput(session, "window_Mbp", "width",
                              1, 0.1, 100)
  })
  
  # Select chromosome. Defaults to blank.
  output$chr_id <- shiny::renderUI({
    shiny::req(project_info())
    choices <- names(pmap_obj())
    selected <- input$chr_id
    if(!isTruthy(selected))
      choices <- c("", choices)
    shiny::selectInput(ns("chr_id"), shiny::strong("chr"),
                choices = choices,
                selected = selected)
  })
  
  ## Window numeric
  output$window_Mbp <- shiny::renderUI({
    shiny::req(project_info())
    if(is.null(win <- input$window_Mbp))
      win <- 1
    shiny::numericInput(ns("window_Mbp"), "width",
                        win, 0.1, 100)
  })
  
  # Peak position slider.
  output$peak_Mbp <- shiny::renderUI({
    shiny::req(project_info(), pmap_obj())
    chr_id <- shiny::req(input$chr_id)
    rng <- round(range(pmap_obj()[[chr_id]]), 2)
    pos <- input$peak_Mbp
    if(is.null(pos)) {
      pos <- round(mean(rng), 2)
    } else {
      if(pos < rng[1] | pos > rng[2])
        pos <- round(mean(rng), 2)
    }
    shiny::numericInput(ns("peak_Mbp"), "pos", 
                        pos, rng[1], rng[2])
  })
  
  ## shorthand 
  output$chr_pos <- shiny::renderUI({
    shiny::req(project_info())
    shiny::textInput(ns("chr_pos"), "pos", input$chr_pos)
  })
  
  scan_tbl <- shinyHotspot("hotspot", set_par, pheno_type, peaks_tbl, pmap_obj, project_info)
  
  shiny::observeEvent(scan_tbl(), {
    update_chr()
    update_peak()
  })
  shiny::observeEvent(input$chr_id, update_peak())
  update_chr <- function() {
    scan_in <- shiny::req(scan_tbl())
    choices <- scan_in$chr[scan_in$count > 0]
    scan_in <- dplyr::filter(scan_in, .data$count == max(.data$count))
    
    chr_ct <- as.character(scan_in$chr)
    if(!any(chr_ct == input$chr_id)) {
      chr_ct <- chr_ct[1]
      shiny::updateSelectInput(session, "chr_id", shiny::strong("chr"),
                               choices, chr_ct)
    }
  }
  update_peak <- function() {
    scan_in <- shiny::req(scan_tbl())
    chr_ct <- shiny::req(input$chr_id)
    scan_in <- dplyr::filter(scan_in, 
                             .data$chr == chr_ct)
    if(nrow(scan_in)) {
      scan_in <- dplyr::filter(scan_in, .data$count == max(.data$count))
      peak_Mbp <- scan_in$pos[1]
    } else {
      peak_Mbp <- input$peak_Mbp
    }
    pmap <- shiny::req(pmap_obj())
    rng <- round(range(pmap[[chr_ct]]), 2)
    shiny::updateNumericInput(session, "peak_Mbp",
                              value=peak_Mbp, 
                              min=rng[1], max=rng[2])
  }
  shiny::observeEvent(input$chr_pos, {
#    chr_pos <- strsplit(input$chr_pos, ":|@|_| |,")[[1]]
#    if(length(chr_pos) == 2) {
#      chr <- chr_pos[1]
#      pmap <- pmap_obj()
#      choices <- names(pmap)
#      if(chr %in% choices) {
#        pos <- as.numeric(chr_pos[2])
    chr <- shiny::req(input$chr_id)
    pos <- as.numeric(input$chr_pos)
    if(is.numeric(pos)) {
      if(!is.na(pos)) {
        pmap <- shiny::req(pmap_obj())
        rng <- round(range(pmap[[chr]]), 2)
        if(pos >= rng[1] & pos <= rng[2]) {
          up <- is.null(input$chr_id)
          if(!up) {
            up <- (chr != input$chr_id)
          }
          if(up) {
            shiny::updateSelectInput(session, "chr_id",
                              selected=chr, choices=choices)
          }
          shiny::updateNumericInput(session, "peak_Mbp",
                            value=pos, min=rng[1], max=rng[2])
        }
      }
    }
  })
  
  ## Return.
  input
})
}

shinyPeaksInput <- function(id) {
  ns <- shiny::NS(id)
  shiny::tagList(
    shiny::checkboxInput(ns("local"), "Local Scan in Window?", TRUE),
    shiny::fluidRow(
      shiny::column(4, shiny::uiOutput(ns("chr_id"))),
      shiny::column(4, shiny::uiOutput(ns("peak_Mbp"))),
      shiny::column(4, shiny::uiOutput(ns("window_Mbp")))
    ))
}
shinyPeaksUI <- function(id) {
  ns <- shiny::NS(id)
  shiny::tagList(
    shinyHotspotInput(ns("hotspot")))
}
shinyPeaksOutput <- function(id) {
  ns <- shiny::NS(id)
  shinyHotspotOutput(ns("hotspot"))
}