Commit bc1a53ec authored by Midoux Cedric's avatar Midoux Cedric

panels/richnessB

parent a0165c62
output$richnessBUI <- renderUI({
validate(need(data16S(), ""))
box(
title = "Setting : " ,
width = NULL,
status = "primary",
selectInput(
"richnessBOrder",
label = "Sorting sample : ",
choices = c("..." = 0, sample_variables(data16S()))
),
textInput("richnessBTitle",
label = "Title : ",
value = "Beta diversity heatmap"),
collapsedBox(verbatimTextOutput("richnessBScript"), title = "RCode")
)
})
output$richnessBScript <- renderText({
script <- c(
scriptHead,
"# Plot heatmap of beta diversity",
glue(
"beta <- 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 <- hue_pal()(length(levels(new_factor)))",
"tipColor <- 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$richnessB <- renderPlot({
validate(need(data16S(),
"Requires an abundance dataset"))
beta <-
melt(as(distance(data16S(), method = input$richnessBDist), "matrix"))
colnames(beta) <- c("x", "y", "distance")
if (!is.null(checkNull(input$richnessBOrder)))
{
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 <- hue_pal()(length(levels(new_factor)))
tipColor <-
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$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(), ""))
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(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
)
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)
)))
})
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")))
)
)
)
......@@ -13,6 +13,7 @@ shinyServer
source("panels/heatmap-server.R", local = TRUE)
source("panels/rarefactionCurve-server.R", local = TRUE)
source("panels/richnessA-server.R", local = TRUE)
source("panels/richnessB-server.R", local = TRUE)
source("panels/tree-server.R", local = TRUE)
checkNull <- function(x) {
......@@ -317,215 +318,7 @@ shinyServer
color = checkNull(input$clustCol)
)
})
output$richnessBUI <- renderUI({
validate(need(data16S(), ""))
box(
title = "Setting : " ,
width = NULL,
status = "primary",
selectInput(
"richnessBOrder",
label = "Sorting sample : ",
choices = c("..." = 0, sample_variables(data16S()))
),
textInput("richnessBTitle",
label = "Title : ",
value = "Beta diversity heatmap"),
collapsedBox(verbatimTextOutput("richnessBScript"), title = "RCode")
)
})
output$richnessBScript <- renderText({
script <- c(
scriptHead,
"# Plot heatmap of beta diversity",
glue(
"beta <- 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 <- hue_pal()(length(levels(new_factor)))",
"tipColor <- 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$richnessB <- renderPlot({
validate(need(data16S(),
"Requires an abundance dataset"))
beta <-
melt(as(distance(data16S(), method = input$richnessBDist), "matrix"))
colnames(beta) <- c("x", "y", "distance")
if (!is.null(checkNull(input$richnessBOrder)))
{
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 <- hue_pal()(length(levels(new_factor)))
tipColor <-
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$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(), ""))
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(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
)
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$mdsUI <- renderUI({
validate(need(data16S(), ""))
box(
......
......@@ -5,6 +5,7 @@ source("panels/histoFocus-ui.R", local = TRUE)
source("panels/heatmap-ui.R", local = TRUE)
source("panels/rarefactionCurve-ui.R", local = TRUE)
source("panels/richnessA-ui.R", local = TRUE)
source("panels/richnessB-ui.R", local = TRUE)
source("panels/tree-ui.R", local = TRUE)
shinyUI(dashboardPage(
......@@ -116,33 +117,8 @@ shinyUI(dashboardPage(
rarefactionCurve),
tabPanel(HTML("&alpha;-diversity"),
richnessA),
tabPanel(
HTML("&beta;-diversity"),
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")))
))
),
tabPanel(HTML("&beta;-diversity"),
richnessB),
tabPanel(
"MultiDimensional Scaling",
withLoader(plotOutput("mds", 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