TrenaViz: TrenaViz

Documented in BindingSitesManager

#' import shiny
#' @name BindingSitesManager
#' @rdname BindingSitesManager
#' @aliases BindingSitesManager
#------------------------------------------------------------------------------------------------------------------------
.BindingSitesManager <- setClass ("BindingSitesManager",
                                  representation = representation(
                                     quiet="logical",
                                     state="environment")
                                  )
#------------------------------------------------------------------------------------------------------------------------
setGeneric("addEventHandlers",    signature="obj", function(obj, session, input, output) standardGeneric("addEventHandlers"))
setGeneric("setOrganism",         signature="obj", function(obj, organism) standardGeneric("setOrganism"))
setGeneric("setGenome",           signature="obj", function(obj, genomeName) standardGeneric("setGenome"))
setGeneric("setGenomicRegion",    signature="obj", function(obj, tbl.region) standardGeneric("setGenomicRegion"))
setGeneric("setTF",               signature="obj", function(obj, tf) standardGeneric("setTF"))
setGeneric("createPage",          signature="obj", function(obj) standardGeneric("createPage"))
setGeneric("renderLogos",         signature="obj", function(obj, tfMappingOption) standardGeneric("renderLogos"))
setGeneric("removeLogos",         signature="obj", function(obj) standardGeneric("removeLogos"))
setGeneric("displayPage",         signature="obj", function(obj, tf) standardGeneric("displayPage"))
#------------------------------------------------------------------------------------------------------------------------
#' Create an BindingSitesManager object
#'
#' @description
#' a shiny app
#'
#' @rdname BindingSitesManager
#'
#' @param organism  A character string, one of the supported species names:  hsapiens, mmuscuulus
#' @param genome  A character string, one of the supported genome builds: hg38, mm10
#' @param quiet A logical indicating whether or not the Trena object should print output
#'
#' @return An object of the BindingSitesManager class
#'
#' @export
#'
BindingSitesManager <- function(quiet=TRUE)
{
   state <- new.env(parent=emptyenv())
   state$TF <- NULL
   state$region <- data.frame(chrom="chr1", start=1, end=2, stringsAsFactors=FALSE)
   state$regionString <- "chr1:1-2"
   state$organism <- NULL
   state$genome <- NULL

   .BindingSitesManager(state=state,  quiet=quiet)

} # BindingSitesManager
#------------------------------------------------------------------------------------------------------------------------
#' specity the organism: Hsapiens, Mmusculus, ...
#'
#' @rdname setOrganism
#' @aliases setOrganism
#'
#' @param obj An object of class BindingSitesManager
#' @param organism character string: Hsapiens, Mmusculus
#'
#' @export
#'
setMethod("setOrganism", "BindingSitesManager",

     function(obj, organism) {
        stopifnot(organism %in% c("Hsapiens", "Mmusculus"))
        obj@state$organism <- organism
        })

#------------------------------------------------------------------------------------------------------------------------
#' specity the genome build: hg38, mm10, ...
#'
#' @rdname setGenome
#' @aliases setGenome
#'
#' @param obj An object of class BindingSitesManager
#' @param genome build character string: hg38, mm10, ...
#'
#' @export
#'
setMethod("setGenome", "BindingSitesManager",

     function(obj, genomeName) {
        obj@state$genome <- genomeName
        })

#------------------------------------------------------------------------------------------------------------------------
#' specity the tf (transcription factor) to work on
#'
#' @rdname setTF
#' @aliases setTF
#'
#' @param obj An object of class BindingSitesManager
#' @param TF character string, the transcription factor we are currently concerned with
#'
#' @export
#'
setMethod("setTF", "BindingSitesManager",

     function(obj, tf) {
        obj@state$TF <- tf
        js$setBindingSitesManagerPageTitle(tf)
          # disable some buttons
        shinyjs::disable("findMatchesButton")
        shinyjs::disable("displayTrackButton")
        js$clear_textInput_exploreAnotherTF()
        })

#------------------------------------------------------------------------------------------------------------------------
#' specify the one or more genomic regions in which to look for binding sites
#'
#' @rdname setGenomicRegion
#' @aliases setGenomicRegion
#'
#' @param obj An object of class BindingSitesManager
#' @param tbl.region a data.frame containing a single (?) genonmic region
#'
#' @export
#'
setMethod("setGenomicRegion", "BindingSitesManager",

     function(obj, tbl.region) {
        #if(all(tbl.region == obj@state$region))
        #   return()
        #printf("--- entering bsm:setGenomicRegion")
        #print(tbl.region)
        if(nrow(tbl.region) == 0) return()
        #print(tbl.region)
        new.roi <- with(tbl.region, sprintf("%s:%d-%d", chrom, start, end))
        new.region.requested <- !(all(tbl.region == obj@state$region))
        obj@state$region <- tbl.region
        if(new.region.requested){
           #printf("--- BindingSitesManager, new genomic region: %s", new.roi)
           obj@state$region <- tbl.region
           obj@state$regionSize <- with(tbl.region, 1 + end - start)
           obj@state$regionString <- new.roi
           genomicRegionsString <- sprintf("%s  (%d bases)", new.roi, with(tbl.region, 1 + end - start))
           if(!is.null(js$setBindingSitesManagerGenomicRegionDisplay))  # not initialized on very early calls
              js$setBindingSitesManagerGenomicRegionDisplay(genomicRegionsString)
           } # if new
        })

#------------------------------------------------------------------------------------------------------------------------
#' create and return the control-rich UI
#'
#' @rdname createPage
#' @aliases createPage
#'
#' @param obj An object of class BindingSitesManager
#'
#' @export
#'
setMethod("createPage", "BindingSitesManager",

      function(obj) {
         div(id="bindingSitesManagerPageContent",
            extendShinyjs(script=system.file(package="TrenaViz", "js", "bindingSitesManager.js")),
            #fluidRow(
            #   column(12, offset=0, h3(id="bindingSitesManagerPageTitle",
            #                          sprintf("Explore Binding Sites for %s: %s (%d bases)",
            #                                  obj@state$TF, obj@state$regionString, obj@state$regionSize)))),
            #br(),
            fluidRow(
               column(3,
                      radioButtons("tfMotifMappingOptions", "TF-Motif Mapping Options",
                                  c("MotifDb", "TFClass", "both"), selected="MotifDb", inline=TRUE),
                      actionButton("displayMotifsButton", "Display Motifs")),
               column(3,
                      selectInput("motifChooser", "Choose Motif", c()),
                      selectInput("matchAlgorithmChooser", "Choose Match Algorithm",
                                  c("Biostrings matchPWM", "MOODS matchMotifs"),
                                  selected="MOODS matchMotifs",
                                  selectize=FALSE)),

               column(4,
                      conditionalPanel(
                         condition = "input.matchAlgorithmChooser == 'Biostrings matchPWM'",
                         sliderInput("biostringsMatchThresholdSlider", "Match Threshold (0-1): ",
                                     min=0, max=1, value=0.9, step=0.01)),
                      conditionalPanel(
                         condition = "input.matchAlgorithmChooser == 'MOODS matchMotifs'",
                         sliderInput("moodsMatchThresholdSlider", "Match Threshold: (-log10(pVal))",
                                     min=0.0, max=8.0, value=4.0, step=0.1)),
                      fluidRow(column(width=3, actionButton("findMatchesButton", "Find Matches")),
                               column(width=2, offset=0, textOutput(outputId="motifMatchCountDisplay")),
                               #column(width=3, offset=2, verbatimTextOutput(outputId="motifMatchCountDisplay", placeholder=TRUE)),
                               column(width=3, actionButton("displayTrackButton", "Display Track")))
                      )), # column3, fluidRow
            fluidRow(id="motifPlottingRow",
                     plotOutput(outputId="motifRenderingPanel", height="1000px"))
            )
       })

#------------------------------------------------------------------------------------------------------------------------
#' show the control-rich UI
#'
#' @rdname renderLogos
#' @aliases renderLogos
#'
#' @param obj An object of class BindingSitesManager
#'
#' @export
#'
setMethod("renderLogos", "BindingSitesManager",

    function(obj, tfMappingOption){

      tf <- obj@state$TF
      mappingOptions <- tolower(tfMappingOption)
      if(tfMappingOption == "both")
        mappingOptions <- c("motifdb", "tfclass")

      pwms.tfClass.longNames <- c()
      motifNames.motifDb <- c()

      if("tfclass" %in% mappingOptions){
         motifNames.tfClass <- geneToMotif(MotifDb, tf, source="TFClass", ignore.case=TRUE)$motif
         printf("tfClass motifs: %d", length(motifNames.tfClass))
         if(length(motifNames.tfClass) > 0)
            pwms.tfClass.longNames <- names(query(MotifDb, obj@state$organism, motifNames.tfClass))
         } # if tfclass

      if("motifdb" %in% mappingOptions){
         pwms.motifDb <- c()
         motifNames.motifDb <- rownames(geneToMotif(MotifDb, tf, source="MotifDb", ignore.case=TRUE))
         printf("motifDb motifs: %d", length(motifNames.motifDb))
         }

      pwm.names.unique <- unique(c(pwms.tfClass.longNames, motifNames.motifDb))
       if(length(pwm.names.unique) == 0){
          showNotification("No motifs found with specified mapping")
          return()
          }
      printf("about to update motifChooser selectInput with %d motif names", length(pwm.names.unique))
      updateSelectInput(obj@state$session, "motifChooser", choices=pwm.names.unique, selected=character(0))
      #shinyjs::enable("displayTrackButton")
      all.pwms <- MotifDb[pwm.names.unique]
      printf("launching ggseqlogo, %d matrices", length(all.pwms))
      show("BindingSitesManager: renderLogos, about to call ggseqlogo")
      ggseqlogo(lapply(all.pwms, function(pwm) pwm))
      })

#------------------------------------------------------------------------------------------------------------------------
#' remove the image
#'
#' @rdname removeLogos
#' @aliases removeLogos
#'
#' @param obj An object of class BindingSitesManager
#'
#' @export
#'
setMethod("removeLogos", "BindingSitesManager",

    function(obj){
       #shinyjs::enable("motifChooser")
       #shinyjs::disable("findMatchesButton")
       #shinyjs::disable("displayTrackButton")
       removeUI(selector="#motifRenderingPanel > img", immediate=TRUE)
       })

#------------------------------------------------------------------------------------------------------------------------
#' display the page
#'
#' @rdname displayPage
#' @aliases displayPage
#'
#' @param obj An object of class BindingSitesManager
#' @param tf  character string, the geneSymbol name of the transcription factor
#'
#' @export
#'
setMethod("displayPage", "BindingSitesManager",

     function(obj, tf){
         removeLogos(obj)
         printf("BindingSitesManager displayPage, tf: %s",   tf)
         #browser()
         setTF(obj, tf)
         removeUI(selector="#bindingSitesManagerPageContent", immediate=TRUE)
         insertUI(selector="#bindingSitesManagerPage", where="afterEnd", createPage(obj), immediate=TRUE)
         updateTabItems(obj@state$session, "sidebarMenu", select="bindingSitesManagerTab")
         removeLogos(obj)
         #printf("about to go red")
         #js$pageRed()
         #printf("after going red")
         })

#------------------------------------------------------------------------------------------------------------------------
#' add shiny event handlers
#'
#' @rdname addEventHandlers
#' @aliases addEventHandlers
#'
#' @param obj An object of class BindingSitesManager
#' @param session a Shiny session object
#' @param input a Shiny input object
#' @param output a Shiny output object
#'
#' @export
#'
setMethod("addEventHandlers", "BindingSitesManager",

     function(obj, session, input, output){

       obj@state$session <- session
       obj@state$input <- input
       obj@state$output <- output

       js$installBindingSitesManagerReturnKeyHandlers()

       observeEvent(input$tfSelector, ignoreInit=TRUE, {
          tf <- input$tfSelector
          if(nchar(tf) == 0) return();
          displayPage(obj, tf)
          })

        observeEvent(input$displayMotifsButton, ignoreInit=TRUE, {
           #js$installReturnHandler()
           #js$pageRed()
           if(!obj@quiet) printf("-- about to enable and disable")
           output$motifRenderingPanel <- renderPlot({
              if(!obj@quiet) printf("observing displayMotifsButton")
              tfMapping <- isolate(input$tfMotifMappingOptions)
              xyz <- "just before render logos"
              renderLogos(obj, tfMapping)
              })
           })

        observeEvent(input$textInput_exploreAnotherTF_widget_returnKey, {
           new.tf <- isolate(input$textInput_exploreAnotherTF)
           if(!obj@quiet) printf("explore this new TF: %s", new.tf)
           if(nchar(new.tf) == 0) return();
           displayPage(obj, new.tf)
           })

        observeEvent(input$findMatchesButton, ignoreInit=TRUE, {
           motif <- isolate(input$motifChooser)
           if(!obj@quiet) print(obj@state$region)
           output$motifMatchCountDisplay <- renderText({"   "})
           sequenceMatchAlgorithm <- isolate(input$matchAlgorithmChooser)
           matchThreshold <- isolate(input$biostringsMatchThresholdSlider)
           if(sequenceMatchAlgorithm == "MOODS matchMotifs")
              matchThreshold <- isolate(input$moodsMatchThresholdSlider)
           motif.matrix <- as.list(MotifDb[motif])
           if(!obj@quiet){
              printf("--- matching motif against current sequence")
              printf("    %s", sequenceMatchAlgorithm)
              printf("    %f", matchThreshold)
              printf("    %s", motif)
              }
           m4 <- MultiMethodMotifMatcher(obj@state$genome, motif.matrix, obj@state$region, sequenceMatchAlgorithm, matchThreshold)
           tbl.hits <- matchMotifInSequence(m4)
           rowCountAsString <- sprintf("%d", nrow(tbl.hits))
           if(!obj@quiet) printf("hits: %s", rowCountAsString)
           output$motifMatchCountDisplay <- renderText({rowCountAsString})
           if(nrow(tbl.hits) == 0)
              shinyjs::disable("displayTrackButton")
           else
              shinyjs::enable("displayTrackButton")
           obj@state$motifHits <- tbl.hits
           #mm <- MotifMatcher("hg38", as.list(pwm.oi), quiet=TRUE)
           # matchThreshold <- 80
           # tbl.matches <- findMatchesByChromosomalRegion(mm, tbl.region, pwmMatchMinimumAsPercentage=matchThreshold)
           # if(nrow(tbl.matches) > 0){
           #    tbl.tmp <- tbl.matches[, c("chrom", "motifStart", "motifEnd", "motifRelativeScore")]
           #    colnames(tbl.tmp) <- c("chrom", "start", "end", "value")
           #    state$colorNumber <- (state$colorNumber %% totalColorCount) + 1
           #    next.color <- colors[state$colorNumber]
           #    scale.bottom <- 0.9 * (matchThreshold/100)
           #    loadBedGraphTrack(session, tf.name, tbl.tmp, color=next.color, trackHeight=25, autoscale=FALSE,
           #    min=scale.bottom, max=1.0)
           #    }
           })

        observeEvent(input$motifChooser, ignoreInit=FALSE, {
           currentValue <- input$motifChooser
           if(!obj@quiet) printf("observer detects motifChooser event: '%s'", currentValue)
           if(nchar(currentValue) == 0){
              shinyjs::disable("findMatchesButton")
              shinyjs::disable("displayTrackButton")
              }
           else{
              shinyjs::enable("findMatchesButton")
              shinyjs::enable("displayTrackButton")
              }
           })

        observeEvent(input$displayTrackButton, ignoreInit=TRUE, {
           if(!obj@quiet) printf("display tracks")
           next.color <- "purple"
           if(!obj@quiet) print(head(obj@state$motifHits))
           motif <- isolate(input$motifChooser)
           tbl.bed <- obj@state$motifHits[, c("chrom", "start", "end", "score")]
           #browser()
           tbl.bed$name <- motif
           tbl.bed <- tbl.bed[, c("chrom", "start", "end", "name", "score")]
           tbl.bed$score <- 20 * tbl.bed$score   # 0-1000 is the bed file range, inflate to that approximate range
           #tbl.bed$score <- as.character(tbl.bed$score)
           #tbl.bed$score <- as.integer(tbl.bed$score)
           #loadBedTrack(session, sprintf("Bi-%s", obj@state$TF), tbl.bed, color=next.color, trackHeight=50)
           updateTabItems(session, "sidebarMenu", select="igvAndTable")
           later(function(){loadBedTrack(obj@state$session, obj@state$TF, tbl.bed,
                                         color=next.color, trackHeight=50, quiet=FALSE)}, 1)
           })
     }) # addEventHandlers

#------------------------------------------------------------------------------------------------------------------------
#          signature="obj", function(obj, session, input, output) standardGeneric("createPage"))
#
#       dialog <- bindingSitesOptionsDialog(tf.name)
#       showModal(dialog)
#       motifNames.tfClass <- geneToMotif(MotifDb, tf.name, source="TFClass")$motif
#       pwms.tfClass <- query(MotifDb, "", motifNames.tfClass)
#       motifNames.motifDb <- geneToMotif(MotifDb, tf.name, source="MotifDb")
#       full.motif.names <- rownames(geneToMotif(MotifDb, tf.name, source="MotifDb"))
#       pwms.motifDb <- MotifDb[full.motif.names]
#       pwm.name.oi <- c(names(pwms.tfClass), names(pwms.motifDb))[1]
#       pwm.oi <- MotifDb[pwm.name.oi]
#       tbl.region <- with(chrom.loc, data.frame(chrom=chrom, start=start, end=end, stringsAsFactors=FALSE))
#       mm <- MotifMatcher("hg38", as.list(pwm.oi), quiet=TRUE)
#       matchThreshold <- 80
#       tbl.matches <- findMatchesByChromosomalRegion(mm, tbl.region, pwmMatchMinimumAsPercentage=matchThreshold)
#       if(nrow(tbl.matches) > 0){
#          tbl.tmp <- tbl.matches[, c("chrom", "motifStart", "motifEnd", "motifRelativeScore")]
#          colnames(tbl.tmp) <- c("chrom", "start", "end", "value")
#          state$colorNumber <- (state$colorNumber %% totalColorCount) + 1
#          next.color <- colors[state$colorNumber]
#          scale.bottom <- 0.9 * (matchThreshold/100)
#          loadBedGraphTrack(session, tf.name, tbl.tmp, color=next.color, trackHeight=25, autoscale=FALSE,
#                            min=scale.bottom, max=1.0)
#          }