mod_heatmap.R

#' heatmap UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom plotly plotlyOutput
#' @importFrom shiny NS radioButtons selectizeInput sliderInput tagList textInput
#' @importFrom shinycssloaders withSpinner
#' @importFrom shinydashboard box
mod_heatmap_ui <- function(id) {
  ns <- NS(id)
  tagList(
    plotlyOutput(ns("heatmap"), height = 700) |>
      withSpinner(),
    box(
      title = "Settings : ",
      width = NULL,
      status = "primary",
      col_6(
        radioButtons(
          ns("heatmapTaxaGlom"),
          label = "Taxonomic level for agglomerating taxa : ",
          choices = "", selected = NULL, inline = TRUE
        )
      ),
      col_6(
        sliderInput(
          ns("heatmapTaxaNb"),
          label = "Show the n most abundant taxa : ",
          min = 1, max = 500, value = 250
        )
      ),
      col_4(
        selectizeInput(
          ns("heatmapGrid"),
          label = "Subplot : ",
          choices = NULL
        )
      ),
      col_4(
        selectizeInput(
          ns("heatmapSampleLabel"),
          label = "Sample label : ",
          choices = NULL
        )
      ),
      col_4(
        selectizeInput(
          ns("heatmapSampleOrder"),
          label = "Sample order : ",
          choices = NULL
        )
      ),
      col_6(
        radioButtons(
          ns("heatmapTaxaLabel"),
          label = "Taxa label : ",
          choices = "", selected = NULL, inline = TRUE
        )
      ),
      col_6(
        textInput(
          ns("heatmapTitle"),
          label = "Title : ",
          value = "Taxa abundance heatmap"
        )
      )
    )
  )
}

#' heatmap Server Functions
#'
#' @noRd
#' @importFrom ggplot2 element_blank element_text facet_grid theme theme_bw vars
#' @importFrom phyloseq otu_table plot_heatmap
#' @importFrom plotly renderPlotly
#' @importFrom rlang .data is_null
#' @importFrom shiny moduleServer need observeEvent reactive validate
mod_heatmap_server <- function(id, r) {
  moduleServer(id, function(input, output, session) {
    ns <- session$ns

    output$heatmap <- renderPlotly({
      validate(
        need(slot_phyloseq(r$physeq), message = "Requires an abundance dataset"),
        need(min(otu_table(r$physeq)) >= 0, message = "Transformation introduced negative counts"),
        need(slot_phyloseq(r$physeq, "tax_table"), message = "Requires tax_table")
      )

      physeq_small <- glom_and_prune(r$physeq, taxrank = nullify(input$heatmapTaxaGlom), n = input$heatmapTaxaNb)

      p <- plot_heatmap(
        physeq = physeq_small,
        method = "NMDS",
        distance = "bray",
        sample.label = nullify(input$heatmapSampleLabel),
        sample.order = nullify(input$heatmapSampleOrder),
        taxa.label = nullify(input$heatmapTaxaLabel),
        low = "yellow",
        high = "red",
        na.value = "white",
        title = nullify(input$heatmapTitle)
      ) +
        switch(not_null(nullify(input$heatmapGrid)),
          facet_grid(cols = vars(.data[[input$heatmapGrid]]), scales = "free_x", space = "free")
        ) +
        theme_bw() +
        theme(
          axis.text.x = element_text(angle = 90),
          axis.title.x = element_blank()
        )

      easy_ggplotly(p = p, tooltip = c("Sample", "OTU"), filename = "heatmap", r = r)
    })

    observeEvent(
      r$physeq,
      {
        updateRanksToRadio(session, "heatmapTaxaGlom", addOTU = TRUE, selected = c("OTU" = ""), reactive(r$physeq))
        updateVariableToSelectize(session, "heatmapGrid", reactive(r$physeq))
        updateVariableToSelectize(session, "heatmapSampleLabel", reactive(r$physeq))
        updateVariableToSelectize(session, "heatmapSampleOrder", reactive(r$physeq))
      }
    )

    observeEvent(
      c(r$physeq, nullify(input$heatmapTaxaGlom)),
      # ignoreNULL = FALSE,
      {
        updateRanksToRadio(session, "heatmapTaxaLabel", addOTU = TRUE, selected = ifelse(is_null(nullify(input$heatmapTaxaGlom)), c("OTU" = ""), nullify(input$heatmapTaxaGlom)), reactive(r$physeq), lower = nullify(input$heatmapTaxaGlom))
      }
    )
  })
}

## To be copied in the UI
# mod_heatmap_ui("heatmap")

## To be copied in the server
# mod_heatmap_server("heatmap", r = r)