Skip to content

GitLab

E
easy16S
Commit e25c1985 authored by Midoux Cedric's avatar Midoux Cedric
Browse files
Options

richess beta : heatmap + table

parent 6635a0a3
Hide whitespace changes
Inline Side-by-side
Showing with 134 additions and 204 deletions
panels/richnessB-server.R
View file @ e25c1985
output$richnessBUI <- renderUI({
validate(need(data16S(), ""))
# output$betaClusterUI
# output$betaCluster
output$betaHeatmapUI <- renderUI({
validate(need(physeq(), ""))
box(
title = "Setting : " ,
width = NULL,
status = "primary",
selectInput(
"richnessBOrder",
label = "Sorting sample : ",
choices = c("..." = 0, sample_variables(data16S()))
selectInput("betaHeatmapOrder",
label = "Sorting sample : ",
choices = c("..." = 0, sample_variables(physeq()))
),
textInput("richnessBTitle",
textInput("betaHeatmapTitle",
label = "Title : ",
value = "Beta diversity heatmap"),
collapsedBox(verbatimTextOutput("richnessBScript"), title = "RCode")
value = "Beta diversity heatmap")
)
})
output$richnessBScript <- renderText({
script <- c(
scriptHead,
"# Plot heatmap of beta diversity",
glue(
"beta <- data.table::melt(as(distance(data, method = \"{input$richnessBDist}\"), \"matrix\"))"
),
"colnames(beta) <- c(\"x\", \"y\", \"distance\")"
)
if (!is.null(checkNull(input$richnessBOrder))) {
script <- c(
script,
glue(
"new_factor = as.factor(get_variable(data, \"{input$richnessBOrder}\"))"
),
glue(
"variable_sort <- as.factor(get_variable(data, \"{input$richnessBOrder}\")[order(new_factor)])"
),
"L = levels(reorder(sample_names(data), as.numeric(new_factor)))",
"beta$x <- factor(beta$x, levels = L)",
"beta$y <- factor(beta$y, levels = L)",
"palette <- scales::hue_pal()(length(levels(new_factor)))",
"tipColor <- scales::col_factor(palette, levels = levels(new_factor))(variable_sort)"
)
} else {
script <- c(script, "tipColor <- NULL")
}
script <-
c(
script,
"",
"p1 <- ggplot(beta, aes(x = x, y = y, fill = distance))",
"p1 <- p1 + geom_tile()"
)
if (!is.null(checkNull(input$richnessBTitle))) {
script <- c(script,
glue("p1 <- p1 + ggtitle(\"{input$richnessBTitle}\")"))
}
script <- c(
script,
glue(
"p1 <- p1 + theme(axis.text.x = element_text(angle = 90, hjust = 1, color = tipColor), axis.text.y = element_text(color = tipColor), axis.title.x = element_blank(), axis.title.y = element_blank())"
)
)
script <- c(script, "", "plot(p1 + scale_fill_gradient2())")
script <- c(script, "", "# Tables")
script <- c(
script,
glue("t <- distance(data, method = \"{input$richnessBDist}\")"),
"write.table(t, file = \"distance.tsv\", sep = \"\\t\", col.names = NA)"
)
return(glue_collapse(script, sep = "\n"))
})
output$betaHeatmap <- metaRender2(renderPlot, {
validate(need(physeq(), "Requires an abundance dataset"))
data <- physeq()
output$richnessB <- renderPlot({
validate(need(data16S(),
"Requires an abundance dataset"))
beta <-
data.table::melt(as(distance(data16S(), method = input$richnessBDist), "matrix"))
colnames(beta) <- c("x", "y", "distance")
if (!is.null(checkNull(input$richnessBOrder)))
if (!is.null(checkNull(input$betaHeatmapOrder)))
{
new_factor = as.factor(get_variable(data16S(), input$richnessBOrder))
variable_sort <-
as.factor(get_variable(data16S(), input$richnessBOrder)[order(new_factor)])
L = levels(reorder(sample_names(data16S()), as.numeric(new_factor)))
beta$x <- factor(beta$x, levels = L)
beta$y <- factor(beta$y, levels = L)
palette <- scales::hue_pal()(length(levels(new_factor)))
tipColor <-
scales::col_factor(palette, levels = levels(new_factor))(variable_sort)
metaExpr({
beta <- reshape2::melt(as.matrix(distance(data, method = ..(input$betaDistance))))
colnames(beta) <- c("x", "y", "distance")
new_factor = as.factor(get_variable(data, ..(input$betaHeatmapOrder)))
variable_sort <- as.factor(get_variable(data, ..(input$betaHeatmapOrder))[order(new_factor)])
L = levels(reorder(sample_names(data), as.numeric(new_factor)))
beta$x <- factor(beta$x, levels = L)
beta$y <- factor(beta$y, levels = L)
palette <- scales::hue_pal()(length(levels(new_factor)))
tipColor <- scales::col_factor(palette, levels = levels(new_factor))(variable_sort)
p <- ggplot(beta, aes(x = x, y = y, fill = distance)) + geom_tile()
p <- p + ggtitle(..(input$betaHeatmapTitle))
p <- p + theme(
axis.text.x = element_text(angle = 90, hjust = 1, color = tipColor),
axis.text.y = element_text(color = tipColor),
axis.title.x = element_blank(),
axis.title.y = element_blank())
p + scale_fill_gradient2()
})
} else {
metaExpr({
beta <- reshape2::melt(as.matrix(distance(data, method = ..(input$betaDistance))))
colnames(beta) <- c("x", "y", "distance")
p <- ggplot(beta, aes(x = x, y = y, fill = distance)) + geom_tile()
p <- p + ggtitle(..(input$betaHeatmapTitle))
p <- p + theme(
axis.text.x = element_text(angle = 90, hjust = 1),
axis.title.x = element_blank(),
axis.title.y = element_blank())
p + scale_fill_gradient2()
})
}
p <-
ggplot(beta, aes(x = x, y = y, fill = distance)) + geom_tile()
p <- p + ggtitle(input$richnessBTitle) + theme(
axis.text.x = element_text(
angle = 90,
hjust = 1,
color = checkNull(tipColor)
),
axis.text.y = element_text(color = checkNull(tipColor)),
axis.title.x = element_blank(),
axis.title.y = element_blank()
)
return(p + scale_fill_gradient2())
})
output$networkBUI <- renderUI({
validate(need(data16S(), ""))
observeEvent(input$betaHeatmap_output_code,
{
displayCodeModal(
expandChain(
quote(library(phyloseq)),
quote(library(phyloseq.extended)),
"# Replace `data` with you own data.",
output$betaHeatmap()
)
)
}
)
output$betaTable <- renderUI({
validate(need(physeq(), "Requires an abundance dataset"))
box(
title = "Setting : " ,
title = "Distance table",
width = NULL,
status = "primary",
sliderInput(
"netwMax",
label = "Threshold : ",
min = 0,
max = 1,
value = 0.7
),
checkboxInput("netwOrphan",
label = "Keep orphans",
value = TRUE),
textInput("netwTitle",
label = "Title : ",
value = "Beta diversity network"),
selectInput(
"netwCol",
label = "Color : ",
choices = c("..." = 0, sample_variables(data16S()))
),
selectInput(
"netwShape",
label = "Shape : ",
choices = c("..." = 0, sample_variables(data16S()))
),
selectInput(
"netwLabel",
label = "Label : ",
choices = c(
"..." = 0,
"Sample name" = "value",
sample_variables(data16S())
)
),
collapsedBox(verbatimTextOutput("networkBScript"), title = "RCode")
)
})
output$networkBScript <- renderText({
scriptArgs <- c("g",
"physeq = data",
"hjust = 2")
if (!is.null(checkNull(input$netwCol))) {
scriptArgs <- c(scriptArgs, glue("color = \"{input$netwCol}\""))
}
if (!is.null(checkNull(input$netwShape))) {
scriptArgs <- c(scriptArgs, glue("shape = \"{input$netwShape}\""))
}
if (!is.null(checkNull(input$netwLabel))) {
scriptArgs <- c(scriptArgs, glue("label = \"{input$netwLabel}\""))
}
if (!is.null(checkNull(input$netwTitle))) {
scriptArgs <- c(scriptArgs, glue("title = \"{input$netwTitle}\""))
}
script <- c(
scriptHead,
"# Plot samples network",
glue(
"g <- make_network(data, distance = \"{input$richnessBDist}\", max.dist = {input$netwMax}, keep.isolates = {input$netwOrphan})"
),
glue("p <- plot_network({glue_collapse(scriptArgs, sep=', ')})")
)
script <- c(script, "", "plot(p)")
return(glue_collapse(script, sep = "\n"))
})
output$networkB <- renderPlot({
validate(need(data16S(),
"Requires an abundance dataset"))
g <- make_network(
data16S(),
distance = input$richnessBDist,
max.dist = input$netwMax,
keep.isolates = input$netwOrphan
beautifulTable(tibble::rownames_to_column(as.data.frame(round(as.matrix(distance(physeq(), method = input$betaDistance)), digits = 2)), var = "SAMPLE"))
)
p <- plot_network(
g,
physeq = data16S(),
color = checkNull(input$netwCol),
shape = checkNull(input$netwShape),
label = checkNull(input$netwLabel),
hjust = 2,
title = checkNull(input$netwTitle)
)
return(p)
})
output$richnessBTable <- renderUI({
validate(need(data16S(),
"Requires an abundance dataset"))
p(beautifulTable(data.frame(
SAMPLE = sample_names(data16S()), round(as.matrix(
distance(data16S(), method = input$richnessBDist)
), digits = 2)
)))
})
# output$networkBUI <- renderUI({
# validate(need(physeq(), ""))
# box(
# title = "Setting : " ,
# width = NULL,
# status = "primary",
# sliderInput(
# "netwMax",
# label = "Threshold : ",
# min = 0,
# max = 1,
# value = 0.7
# ),
# checkboxInput("netwOrphan",
# label = "Keep orphans",
# value = TRUE),
# textInput("netwTitle",
# label = "Title : ",
# value = "Beta diversity network"),
# selectInput(
# "netwCol",
# label = "Color : ",
# choices = c("..." = 0, sample_variables(physeq()))
# ),
# selectInput(
# "netwShape",
# label = "Shape : ",
# choices = c("..." = 0, sample_variables(physeq()))
# ),
# selectInput(
# "netwLabel",
# label = "Label : ",
# choices = c(
# "..." = 0,
# "Sample name" = "value",
# sample_variables(physeq())
# )
# )
# )
# })
#
# output$networkB <- renderPlot({
# validate(need(physeq(),
# "Requires an abundance dataset"))
# g <- make_network(
# physeq(),
# distance = input$betaDistance,
# max.dist = input$netwMax,
# keep.isolates = input$netwOrphan
# )
# p <- plot_network(
# g,
# physeq = physeq(),
# color = checkNull(input$netwCol),
# shape = checkNull(input$netwShape),
# label = checkNull(input$netwLabel),
# hjust = 2,
# title = checkNull(input$netwTitle)
# )
# return(p)
# })
#
panels/richnessB-ui.R
View file @ e25c1985
richnessB <- fluidPage(
selectInput("richnessBDist",
label = "Distance : ",
choices = list("bray", "jaccard", "unifrac", "wunifrac", "dpcoa", "jsd", "euclidean")),
box(width = NULL,
tabsetPanel(
tabPanel("Heatmap",
withLoader(plotOutput("richnessB", height = 700)),
uiOutput("richnessBUI")),
tabPanel("Networks",
withLoader(plotOutput("networkB", height = 700)),
uiOutput("networkBUI")),
tabPanel("Tables",
withLoader(uiOutput("richnessBTable")))
)
)
)
betaCluster <- fluidPage(outputCodeButton(withLoader(plotOutput("betaCluster", height = 700))),
uiOutput("betaClusterUI"))
betaHeatmap <- fluidPage(outputCodeButton(withLoader(plotOutput("betaHeatmap", height = 700))),
uiOutput("betaHeatmapUI"))
betaNetworks <- fluidPage(outputCodeButton(withLoader(plotOutput("betaNetworks", height = 700))),
uiOutput("betaNetworksUI"))
betaTable <- fluidPage(uiOutput("betaTable"))
ui.R
View file @ e25c1985
......@@ -38,6 +38,9 @@ dashboardHeader(title = "Easy16S"),
menuSubItem("Table", tabName = "alphaTable")
),
menuItem(HTML("&beta;-diversity"), icon = icon("th"),
selectInput("betaDistance",
label = "Distance : ",
choices = list("bray", "jaccard", "unifrac", "wunifrac", "dpcoa", "jsd", "euclidean")),
menuSubItem("Samples clustering", tabName = "betaCluster"),
menuSubItem("Samples heatmap", tabName = "betaHeatmap"),
menuSubItem("Networks", tabName = "betaNetworks"),
......
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