R/shiny-module-geneSetContrastView.R

In lianos/multiGSEA.shiny: Provides shiny components to visualize multilGSEA results

## This module enables *complete browsing* of the behavior of the genesets in
## a MultiGSEAResultContainer.
##
## Internally it consists of a geneSetSelect module, too.
##
## Note that this module is not concerned with the statistics generated by
## a particular GSEA method, but rather the differential logFC or t-stats for
## the genes in a geneset

##' A module to encapsulate browsing differential statistics of a geneset.
##'
##' @description
##' The module is meant to be displayed in "a box" so that the user can examine
##' the coherent (or not) behavior of the geneset across a contrast with respect
##' to the background distribution of all genes in the contrast.
##'
##' @details
##' Embedded within this module is the \code{\link{geneSetSelect}} module, which
##' provides the list of genesets the user can examine, as well as the title of
##' the current geneset under scrutiny.
##'
##' Below the geneSet picker, we embed an \code{\link{iplot}} so that the
##' user can observe the behavior of the geneset across the contrast. The user
##' can pick the type of plot to show (density or boxplot) as well as which
##' statistics to use for plotting (logFC or t-statistics).
##'
##' A \code{updateActiveGeneSetInContrastView} function is provided to enable
##' interactions external to this module the ability to update the geneset
##' selected in the \code{\link{geneSetSelect}} module.
##'
##' @rdname geneSetContrastViewModule
##' @export
##' @importFrom miniUI miniTabstripPanel miniTabPanel miniContentPanel
##' @importFrom shiny NS tagList tags fluidRow column selectInput downloadButton
##' @importFrom shiny icon downloadHandler
##' @importFrom DT dataTableOutput
##'
##' @param id the shiny id of the module
##' @param height,width the height and width of the module
##' @return \code{geneSetContrastViewUI} returns tagList of html stuff to dump
##'   into the UI.
geneSetContrastViewUI <- function(id, height="590px", width="400px") {
  ns <- NS(id)

  tagList(
    tags$div(
      # class="gadget-container", style=paste("height:", height),
      class="gadget-container",
      style=sprintf("height: %s; width %s;", height, width),
      tags$div(
        style="padding: 0 5px 0 5px",
        geneSetSelectUI(ns("gs_select"), "Select Gene Set")),
      miniTabstripPanel(
        miniTabPanel(
          "Visualize", icon = icon("area-chart"),
          miniContentPanel(
            plotlyOutput(ns("gs_viz"), height="350px"),
            # call with js$reset_gs_viz_selected()
            insertPlotlyReset('gs_viz', 'selected'),
            fluidRow(
              column(
                8,
                selectInput(ns("gs_viz_type"), NULL,
                            c('boxplot', 'density'), 'density')),
              column(
                4,
                selectInput(ns("gs_viz_stat"), NULL,
                            c('logFC'='logFC', 't-statistic'='t'), 'logFC'))
            )
          )
        ), ## Viz miniTabPanel
        miniTabPanel(
          "Genes", icon = icon("table"),
          miniContentPanel(
            DT::dataTableOutput(ns("gs_members")),
            downloadButton(ns("gs_gene_table"), 'Download'))
        ) ## Members Table miniTabPanel
      ) ## miniTabstripPanel
    ) ## div.gadget-container
  ) ## tagList
}

##' @rdname geneSetContrastViewModule
##' @export
##' @importFrom shiny callModule reactive req downloadHandler outputOptions
##' @importFrom DT renderDataTable
##'
##' @inheritParams geneSetSelect
##' @return the \code{geneSetContrastView} module returns a reactive list,
##'   with a \code{$gs} element that indicates the currently active geneset in
##'   the `geneSetSelect` module, and a \code{$selected} element, a character
##'   vector of feature_ids currently brushed in a contrast view.
geneSetContrastView <- function(input, output, session, mgc,
                                server=TRUE, maxOptions=Inf, sep="_::_",
                                feature.link.fn=ncbi.entrez.link,
                                itools=c('wheel_zoom', 'box_select', 'reset', 'save')) {
  gs <- callModule(geneSetSelect, 'gs_select', mgc, server=server,
                   maxOptions=maxOptions, sep=sep)
  plt <- reactive({
    coll <- req(gs()$collection)
    name <- req(gs()$name)
    ns <- session$ns
    js$reset_gs_viz_selected()
    iplot(mgc()$mg, coll, name,
          value=input$gs_viz_stat,
          type=input$gs_viz_type, tools=itools,
          main=NULL, with.legend=FALSE, with.data=TRUE,
          shiny_source='gs_viz', width=350, height=350)

  })

  selected_features <- reactive({
    event <- event_data('plotly_selected', source='gs_viz')
    if (!is.null(event)) {
      out <- event$key
    } else {
      out <- character()
    }
    out
  })

  output$gs_viz <- renderPlotly({
    req(plt())
  })

  # outputOptions(output, "gs_viz", suspendWhenHidden=FALSE)

  output$gs_members <- DT::renderDataTable({
    req(gs())
    gs.stats <- req(gs()$stats)
    if (!is(gs.stats, 'data.table')) {
      # browser()
      req(NULL)
    }
    renderFeatureStatsDataTable(gs.stats, feature.link.fn=feature.link.fn,
                                filter='none')
  }, server=server)

  output$gs_gene_table <- downloadHandler(
    filename=function() {
      sprintf('multiGSEA-gene-statistics-%s_%s.csv', gs()$collection, gs()$name)
    },
    content=function(file) {
      write.csv(gs()$stats, file, row.names=FALSE)
    }
  )

  outputOptions(output, "gs_gene_table", suspendWhenHidden=FALSE)

  vals <- reactive({
    list(gs=gs, selected=selected_features)
  })

  return(vals)
}

##' @rdname geneSetContrastViewModule
is.geneSetContrastViewer <- function(x) {
  is(x, 'reactive') && is(x()$gs, 'reactive') && is(x()$selected, 'reactive')
}

##' @export
##' @importFrom shiny withReactiveDomain
##' @rdname geneSetContrastViewModule
updateActiveGeneSetInContrastView <- function(session, viewer, geneset, mgc) {
  stopifnot(is(mgc, 'MultiGSEAResultContainer'))
  stopifnot(is.geneSetContrastViewer(viewer))
  withReactiveDomain(session, {
    # id <- req(viewer()$gs()$select.id)
    # 2016-12-23
    # Hack to enable this to work within arbitray module nesting levels.
    # This might not be necessary, but it seems like it was because if this
    # module is called from another module, then the `session` object is somehow
    # dispatching its IDs with as many module prefixes as it is being called
    # down from the stack. Since we are calling the geneSet-select module using
    # its global ID, we need to strip out the prefixes that are already assumed
    # to be working here. (also, I doubt this paragraph will make sense when I
    # read it in a few months)
    modname <- sub('-test$', '', session$ns('test'))
    id <- req(viewer()$gs()$select.id)
    id <- sub(paste0(modname, '-'), '', id)
    updateSelectizeInput(session, id, choices=mgc$choices,
                         selected=geneset, server=TRUE)
  })
}