-
Cedric Midoux authoredCedric Midoux authored
mod_heatmap.R 4.20 KiB
#' 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)