Commit 50f74a41 authored by Midoux Cedric's avatar Midoux Cedric

panel/heatmap

parent 34cdaede
output$HeatmapUI <- renderUI({
validate(need(data16S(), ""))
box(
title = "Setting : " ,
width = NULL,
status = "primary",
textInput("heatmapTitle",
label = "Title : ",
value = "Taxa heatmap by samples"),
selectInput(
"heatmapGrid",
label = "Subplot : ",
choices = c("..." = 0, sample_variables(data16S()))
),
selectInput(
"heatmapX",
label = "X : ",
choices = c("..." = 0, sample_variables(data16S()))
),
sliderInput(
"heatmapTopOtu",
label = "Show the n most abundant OTU : ",
min = 1,
max = ntaxa(data16S()),
value = 250
),
selectInput(
"heatmapDist",
label = "Distance : ",
selected = "bray",
choices = list(
"bray",
"jaccard",
"unifrac",
"wunifrac",
"dpcoa",
"jsd",
"euclidean"
)
),
selectInput(
"heatmapMethod",
label = "Method : ",
selected = "NMDS",
choices = list(
"NMDS",
"ward.D2",
"ward.D",
"single",
"complete",
"average",
"mcquitty",
"median",
"centroid"
)
),
collapsedBox(verbatimTextOutput("heatmapScript"), title = "RCode")
)
})
output$heatmapScript <- renderText({
scriptArgs <-
c(
glue(
"prune_taxa(names(sort(taxa_sums(data), decreasing = TRUE)[1:{input$heatmapTopOtu}]), data)"
),
glue("distance = \"{input$heatmapDist}\""),
glue("method = \"{input$heatmapMethod}\""),
"low = \"yellow\"",
"high = \"red\"",
"na.value = \"white\""
)
if (!is.null(checkNull(input$heatmapX))) {
scriptArgs <-
c(scriptArgs, glue("sample.order = \"{input$heatmapX}\""))
}
if (!is.null(checkNull(input$heatmapTitle))) {
scriptArgs <-
c(scriptArgs, glue("title = \"{input$heatmapTitle}\""))
}
script <- c(
scriptHead,
"# Plot heatmap",
glue("p <- plot_heatmap({glue_collapse(scriptArgs, sep=', ')})")
)
if (!is.null(checkNull(input$heatmapGrid))) {
script <- c(
script,
glue(
"p <- p + facet_grid(\". ~ {input$heatmapGrid}\", scales = \"free_x\")"
)
)
}
script <- c(script, "", "plot(p)")
return(glue_collapse(script, sep = "\n"))
})
output$Heatmap <- renderPlot({
validate(need(data16S(),
"Requires an abundance dataset"))
p <- plot_heatmap(
physeq = prune_taxa(names(sort(
taxa_sums(data16S()), decreasing = TRUE
)[1:input$heatmapTopOtu]), data16S()),
distance = input$heatmapDist,
method = input$heatmapMethod,
title = checkNull(input$heatmapTitle),
sample.order = checkNull(input$heatmapX),
low = "yellow",
high = "red",
na.value = "white"
)
if (!is.null(checkNull(input$heatmapGrid))) {
p <-
p + facet_grid(paste(".", "~", input$heatmapGrid), scales = "free_x")
}
return(p)
})
heatmap <- fluidPage(withLoader(plotOutput("Heatmap", height = 700)),
uiOutput("HeatmapUI"))
......@@ -10,6 +10,7 @@ shinyServer
{
source("panels/histo-server.R", local = TRUE)
source("panels/histoFocus-server.R", local = TRUE)
source("panels/heatmap-server.R", local = TRUE)
checkNull <- function(x) {
if (!exists(as.character(substitute(x)))) {
......@@ -763,127 +764,6 @@ shinyServer
return(glue_collapse(script, sep = "\n"))
})
output$HeatmapUI <- renderUI({
validate(need(data16S(), ""))
box(
title = "Setting : " ,
width = NULL,
status = "primary",
textInput("heatmapTitle",
label = "Title : ",
value = "Taxa heatmap by samples"),
selectInput(
"heatmapGrid",
label = "Subplot : ",
choices = c("..." = 0, sample_variables(data16S()))
),
selectInput(
"heatmapX",
label = "X : ",
choices = c("..." = 0, sample_variables(data16S()))
),
sliderInput(
"heatmapTopOtu",
label = "Show the n most abundant OTU : ",
min = 1,
max = ntaxa(data16S()),
value = 250
),
selectInput(
"heatmapDist",
label = "Distance : ",
selected = "bray",
choices = list(
"bray",
"jaccard",
"unifrac",
"wunifrac",
"dpcoa",
"jsd",
"euclidean"
)
),
selectInput(
"heatmapMethod",
label = "Method : ",
selected = "NMDS",
choices = list(
"NMDS",
"ward.D2",
"ward.D",
"single",
"complete",
"average",
"mcquitty",
"median",
"centroid"
)
),
collapsedBox(verbatimTextOutput("heatmapScript"), title = "RCode")
)
})
output$heatmapScript <- renderText({
scriptArgs <-
c(
glue(
"prune_taxa(names(sort(taxa_sums(data), decreasing = TRUE)[1:{input$heatmapTopOtu}]), data)"
),
glue("distance = \"{input$heatmapDist}\""),
glue("method = \"{input$heatmapMethod}\""),
"low = \"yellow\"",
"high = \"red\"",
"na.value = \"white\""
)
if (!is.null(checkNull(input$heatmapX))) {
scriptArgs <-
c(scriptArgs, glue("sample.order = \"{input$heatmapX}\""))
}
if (!is.null(checkNull(input$heatmapTitle))) {
scriptArgs <-
c(scriptArgs, glue("title = \"{input$heatmapTitle}\""))
}
script <- c(
scriptHead,
"# Plot heatmap",
glue("p <- plot_heatmap({glue_collapse(scriptArgs, sep=', ')})")
)
if (!is.null(checkNull(input$heatmapGrid))) {
script <- c(
script,
glue(
"p <- p + facet_grid(\". ~ {input$heatmapGrid}\", scales = \"free_x\")"
)
)
}
script <- c(script, "", "plot(p)")
return(glue_collapse(script, sep = "\n"))
})
output$Heatmap <- renderPlot({
validate(need(data16S(),
"Requires an abundance dataset"))
p <- plot_heatmap(
physeq = prune_taxa(names(sort(
taxa_sums(data16S()), decreasing = TRUE
)[1:input$heatmapTopOtu]), data16S()),
distance = input$heatmapDist,
method = input$heatmapMethod,
title = checkNull(input$heatmapTitle),
sample.order = checkNull(input$heatmapX),
low = "yellow",
high = "red",
na.value = "white"
)
if (!is.null(checkNull(input$heatmapGrid))) {
p <-
p + facet_grid(paste(".", "~", input$heatmapGrid), scales = "free_x")
}
return(p)
})
output$treeUI <- renderUI({
validate(need(phy_tree(data16S(), errorIfNULL = FALSE), ""))
box(
......
......@@ -2,6 +2,7 @@ library(shinydashboard)
library(shinycustomloader)
source("panels/histo-ui.R", local = TRUE)
source("panels/histoFocus-ui.R", local = TRUE)
source("panels/heatmap-ui.R", local = TRUE)
shinyUI(dashboardPage(
dashboardHeader(title = "Easy16S"),
......@@ -107,8 +108,7 @@ shinyUI(dashboardPage(
tabPanel("Filtered barplot",
histFocus),
tabPanel("Heatmap",
withLoader(plotOutput("Heatmap", height = 700)),
uiOutput("HeatmapUI")),
heatmap),
tabPanel(
"Rarefaction curves",
withLoader(plotOutput("rarefactionCurve", height = 700)),
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment