Failed to fetch fork details. Try again later.
-
Midoux Cedric authored5235e20f
Forked from
Midoux Cedric / easy16S
Source project has a limited visibility.
library(shinydashboard)
library(dplyr)
library(glue)
shinyServer
(function(input, output, session)
{
checkNull <- function(x) {
if (!exists(as.character(substitute(x)))) {
return(NULL)
} else if (is.null(x)) {
return(NULL)
} else if (length(x) > 1) {
return(x)
}
else if (x %in% c(0, "", NA, "NULL")) {
return(NULL)
} else {
return(x)
}
}
beautifulTable <- function(data) {
DT::datatable(
data = data,
rownames = FALSE,
filter = "top",
extensions = c("Buttons", "ColReorder", "FixedColumns"),
options = list(
dom = "lBtip",
pageLength = 10,
lengthMenu = list(c(10, 25, 50, 100, -1), list('10', '25', '50', '100', 'All')),
buttons = list(
'colvis',
list(
extend = 'collection',
buttons = c('copy', 'csv', 'excel', 'pdf'),
text = 'Download'
)
),
colReorder = TRUE,
scrollX = TRUE,
fixedColumns = list(leftColumns = 1, rightColumns = 0)
),
width = "auto",
height = "auto"
)
}
collapsedBox <- function(data, title = title) {
box(
title = title,
width = NULL,
status = "primary",
collapsible = TRUE,
collapsed = TRUE,
data
)
}
source({
"https://raw.githubusercontent.com/mahendra-mariadassou/phyloseq-extended/master/R/load-extra-functions.R"
})
source("internals.R")
data16S <- reactive({
## BIOM input
if (input$dataset == "input")
{
7172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140
## Unhappy path
if (is.null(input$fileBiom))
return()
## Happy path
## Import biom
d <- .import_biom(input)
## Format tax table
tax_table(d) <- .format_tax_table(tax_table(d))
## import metadata and store it in phyloseq object
sample_data(d) <- .import_sample_data(input, d)
## Rarefy data
if (input$rareData) {
d <- rarefy_even_depth(
d,
replace = FALSE,
rngseed = as.integer(Sys.time()),
verbose = FALSE
)
}
return(d)
}
## Rdata input
if (input$dataset == "rdata")
{
## .import_from_rdata(input) ## does not work as a function for some reason
## Happy path
ne <-
new.env() ## new env to store RData content and avoid border effects
if (!is.null(input$fileRData))
load(input$fileRData$datapath, envir = ne)
if (class(ne$data) == "phyloseq")
return(ne$data)
## Unhappy paths: everything else
return()
}
## Default case
load("demo/demo.RData")
return(get(input$dataset))
})
data <- reactiveValues()
{
observe({
if (!is.null(data16S()))
isolate(data <<- data16S())
})
}
scriptHead <- c(
"# Loading packages",
"source(\"https://raw.githubusercontent.com/mahendra-mariadassou/phyloseq-extended/master/R/load-extra-functions.R\")",
"",
"# Loading data",
glue(
"load(\"Easy16S-data.{Sys.Date()}.RData\") # if necessary, adapt the file path"
),
"",
"# View data",
"data",
""
)
141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210
output$downloadData <- {
downloadHandler(
filename = function() {
paste("Easy16S-data", Sys.Date(), "RData", sep = ".")
},
content = function(file) {
save(data, file = file)
}
)
}
output$downloadUI <- renderUI({
validate(need(data16S(), ""))
tags$div(
style = "text-align:center",
title = "Download as RData",
downloadButton("downloadData", "Download", style = "color: black; background-color: gray90")
)
})
output$rarefactionMin <- renderText({
validate(need(input$fileBiom, ""),
need(input$dataset == "input", ""))
paste("(min sample =", format(min(sample_sums(data16S(
))), big.mark = " "), "reads)")
})
output$phyloseqPrint <- renderPrint({
validate(
need(
data16S(),
"Firstly, you should select a demo dataset or upload an abundance BIOM file.\nFor example, with Galaxy, a BIOM file can be obtained at the end of FROGS workflow with the 'FROGS BIOM to std BIOM' tool. \nMake sure that the phyloseq object in the RData file is called 'data'."
)
)
data16S()
})
output$sampledataTable <- renderUI({
validate(need(sample_data(data16S(), errorIfNULL = FALSE), ""))
collapsedBox(renderTable({
(sapply(sample_data(data16S()), class))
}, rownames = TRUE, colnames = FALSE),
title = "Class of sample_data")
})
output$summaryTable <- renderUI({
validate(need(data16S(), ""))
box(
title = "Tables",
width = NULL,
status = "primary",
tabsetPanel(
tabPanel("otu_table",
beautifulTable(
data.frame(OTU = taxa_names(data16S()), otu_table(data16S()))
)),
tabPanel("tax_table",
beautifulTable(
data.frame(OTU = taxa_names(data16S()), tax_table(data16S()))
)),
tabPanel("sample_data",
#as.data.frame(sapply(sample_data(data16S()), class)),
beautifulTable(
data.frame(SAMPLE = sample_names(data16S()), sample_data(data16S()))
)),
tabPanel(
"agglomerate_taxa",
radioButtons(
211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280
"glomRank",
label = "Taxonomic rank : ",
choices = rank_names(data16S()),
inline = TRUE
),
DT::dataTableOutput("tableGlom")
)
)
)
})
output$tableGlom <- DT::renderDataTable(server = FALSE, {
Glom <- tax_glom(data16S(), input$glomRank)
taxTableGlom <- Glom %>%
tax_table() %>%
as.data.frame(stringsAsFactors = FALSE) %>%
dplyr::select(input$glomRank:1) %>%
tibble::rownames_to_column()
otuTableGlom <- Glom %>%
otu_table() %>%
as.data.frame(stringsAsFactors = FALSE) %>%
tibble::rownames_to_column()
joinGlom <-
dplyr::left_join(taxTableGlom, otuTableGlom, by = "rowname") %>%
dplyr::select(-rowname)
beautifulTable(joinGlom)
})
output$histUI <- renderUI({
validate(need(data16S(), ""))
box(
title = "Setting : ",
width = NULL,
status = "primary",
radioButtons(
"barFill",
label = "Taxonomic rank : ",
choices = rank_names(data16S()),
inline = TRUE
),
textInput("barTitle",
label = "Title : ",
value = "OTU abundance barplot"),
selectInput(
"barGrid",
label = "Subplot : ",
choices = c("..." = 0, sample_variables(data16S()))
),
selectInput(
"barX",
label = "X : ",
choices = c("..." = 0, sample_variables(data16S()))
),
collapsedBox(verbatimTextOutput("histScript"), title = "RCode")
)
})
output$histScript <- renderText({
scriptArgs <- c("physeq = data",
glue("fill = \"{input$barFill}\""))
if (!is.null(checkNull(input$barX))) {
scriptArgs <- c(scriptArgs, glue("x = \"{input$barX}\""))
}
if (!is.null(checkNull(input$barTitle))) {
scriptArgs <- c(scriptArgs, glue("title = \"{input$barTitle}\""))
}
script <- c(
scriptHead,
"# Plot barplot",
glue("p <- plot_bar({glue_collapse(scriptArgs, sep=', ')})")
281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350
)
if (!is.null(checkNull(input$barGrid))) {
script <- c(script,
glue(
"p <- p + facet_grid(\". ~ {input$barGrid}\", scales = \"free_x\")"
))
}
script <- c(script, "", "plot(p)")
return(glue_collapse(script, sep = "\n"))
})
output$histo <- renderPlot({
validate(need(data16S(),
"Requires an abundance dataset"))
p <- plot_bar(
physeq = data16S(),
fill = input$barFill,
x = ifelse(is.null(checkNull(input$barX)), "Sample", input$barX),
title = checkNull(input$barTitle)
)
if (!is.null(checkNull(input$barGrid))) {
p <-
p + facet_grid(paste(".", "~", input$barGrid), scales = "free_x")
}
return(p)
})
output$histFocusUIfocusRank <- renderUI({
validate(need(data16S(), ""))
radioButtons(
"focusRank",
label = "Taxonomic rank : ",
choices = rank_names(data16S())[-length(rank_names(data16S()))],
inline = TRUE
)
})
output$histFocusUIfocusTaxa <- renderUI({
validate(need(data16S(), ""),
need(input$focusRank, ""))
selectInput(
"focusTaxa",
label = "Selected taxa : ",
choices = unique(as.vector(tax_table(data16S(
))[, input$focusRank])),
selected = TRUE
)
})
output$histFocusUIfocusNbTaxa <- renderUI({
validate(need(data16S(), ""))
sliderInput(
"focusNbTaxa",
label = "Number of sub-taxa : ",
min = 0,
#max = sum(tax_table(tax_glom(data16S(), rank_names(data16S())[1+as.integer(input$focusRank)]))[, as.integer(input$focusRank)]==input$focusTaxa)
max = 30,
value = 10
)
})
output$histFocusUIfocusGrid <- renderUI({
validate(need(data16S(), ""))
selectInput("focusGrid",
label = "Subplot : ",
choices = c("..." = 0, sample_variables(data16S())))
})
351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420
output$histFocusUIfocusX <- renderUI({
validate(need(data16S(), ""))
selectInput("focusX",
label = "X : ",
choices = c("..." = 0, sample_variables(data16S())))
})
output$histFocusUI <- renderUI({
validate(need(data16S(), ""))
box(
title = "Setting : ",
width = NULL,
status = "primary",
uiOutput("histFocusUIfocusRank"),
uiOutput("histFocusUIfocusTaxa"),
uiOutput("histFocusUIfocusNbTaxa"),
uiOutput("histFocusUIfocusGrid"),
uiOutput("histFocusUIfocusX"),
collapsedBox(verbatimTextOutput("histFocusScript"), title = "RCode")
)
})
output$histFocusScript <- renderText({
scriptArgs <- c(
"physeq = data",
glue("taxaRank1 = \"{input$focusRank}\""),
glue("taxaSet1 = \"{input$focusTaxa}\""),
glue(
"taxaRank2 = \"{rank_names(data16S())[which(rank_names(data16S()) == input$focusRank) + 1]}\""
),
glue("numberOfTaxa = {input$focusNbTaxa}"),
glue(
"fill = \"{rank_names(data16S())[which(rank_names(data16S()) == input$focusRank) + 1]}\""
)
)
if (!is.null(checkNull(input$focusX))) {
scriptArgs <- c(scriptArgs, glue("x = \"{input$focusX}\""))
}
script <- c(
scriptHead,
"# Plot filtered barplot",
glue(
"p <- plot_composition({glue_collapse(scriptArgs, sep=', ')})"
)
)
if (!is.null(checkNull(input$focusGrid))) {
script <- c(
script,
glue(
"p <- p + facet_grid(\". ~ {input$focusGrid}\", scales = \"free_x\")"
)
)
}
script <- c(script, "", "plot(p)")
return(glue_collapse(script, sep = "\n"))
})
output$histFocus <- renderPlot({
validate(
need(data16S(),
"Requires an abundance dataset"),
need(input$focusRank, ""),
need(input$focusTaxa, "")
)
p <- plot_composition(
physeq = data16S(),
taxaRank1 = input$focusRank,
taxaSet1 = input$focusTaxa,
taxaRank2 = rank_names(data16S())[which(rank_names(data16S()) == input$focusRank) + 1],
421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490
numberOfTaxa = input$focusNbTaxa,
fill = rank_names(data16S())[which(rank_names(data16S()) == input$focusRank) + 1],
x = ifelse(is.null(checkNull(input$focusX)), "Sample", input$focusX)
)
if (!is.null(checkNull(input$focusGrid))) {
p <-
p + facet_grid(paste(".", "~", input$focusGrid), scales = "free_x")
}
return(p)
})
output$clustUI <- renderUI({
validate(need(data16S(), ""))
box(
title = "Setting : " ,
width = NULL,
status = "primary",
selectInput(
"clustDist",
label = "Distance : ",
choices = list(
"bray",
"jaccard",
"unifrac",
"wunifrac",
"dpcoa",
"jsd",
"euclidean"
)
),
selectInput(
"clustMethod",
label = "Method : ",
choices = list(
"ward.D2",
"ward.D",
"single",
"complete",
"average",
"mcquitty",
"median",
"centroid"
)
),
selectInput(
"clustCol",
label = "Color : ",
choices = c("..." = 0, sample_variables(data16S()))
),
collapsedBox(verbatimTextOutput("clustScript"), title = "RCode")
)
})
output$clustScript <- renderText({
scriptArgs <- c(
"physeq = data",
glue("dist = \"{input$clustDist}\""),
glue("method = \"{input$clustMethod}\"")
)
if (!is.null(checkNull(input$clustCol))) {
scriptArgs <- c(scriptArgs, glue("color = \"{input$clustCol}\""))
}
script <- c(
scriptHead,
"# Plot samples clustering",
glue("p <- plot_clust({glue_collapse(scriptArgs, sep=', ')})")
)
script <- c(script, "", "plot(p)")
return(glue_collapse(script, sep = "\n"))
491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560
})
output$clust <- renderPlot({
validate(need(data16S(),
"Requires an abundance dataset"))
plot_clust(
physeq = data16S(),
dist = input$clustDist,
method = input$clustMethod,
color = checkNull(input$clustCol)
)
})
output$richnessAUI <- renderUI({
validate(need(data16S(), ""))
box(
title = "Setting : " ,
width = NULL,
status = "primary",
checkboxGroupInput(
"richnessMeasures",
label = "Measures : ",
choices = c(
"Observed",
"Chao1",
"ACE",
"Shannon",
"Simpson",
"InvSimpson",
"Fisher"
),
selected = c(
"Observed",
"Chao1",
"ACE",
"Shannon",
"Simpson",
"InvSimpson",
"Fisher"
),
inline = TRUE
),
radioButtons(
"richnessBoxplot",
label = "Representation : ",
choices = list(
"Dots only" = 1,
"Dots and boxplot" = 2,
"Boxplot only" = 3
),
selected = 2,
inline = TRUE
),
textInput("richnessTitle",
label = "Title : ",
value = "Alpha diversity graphics"),
selectInput(
"richnessX",
label = "X : ",
choices = c("..." = 0, sample_variables(data16S()))
),
selectInput(
"richnessColor",
label = "Color : ",
choices = c("..." = 0, sample_variables(data16S()))
),
selectInput(
"richnessShape",
label = "Shape : ",
choices = c("..." = 0, sample_variables(data16S()))
561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630
),
collapsedBox(verbatimTextOutput("richnessAScript"), title = "RCode")
)
})
output$richnessAScript <- renderText({
if (!is.null(checkNull(input$richnessMeasures))) {
measures <-
glue("measures = c(\"{glue_collapse(input$richnessMeasures, sep='\", \"')}\")")
} else {
measures <- NULL
}
scriptArgs <- c("physeq = data", measures)
if (!is.null(checkNull(input$richnessX))) {
scriptArgs <- c(scriptArgs, glue("x = \"{input$richnessX}\""))
}
if (!is.null(checkNull(input$richnessColor))) {
scriptArgs <-
c(scriptArgs, glue("color = \"{input$richnessColor}\""))
}
if (!is.null(checkNull(input$richnessShape))) {
scriptArgs <-
c(scriptArgs, glue("shape = \"{input$richnessShape}\""))
}
if (!is.null(checkNull(input$richnessTitle))) {
scriptArgs <-
c(scriptArgs, glue("title = \"{input$richnessTitle}\""))
}
script <- c(
scriptHead,
"# Plot boxplot of alpha diversity",
glue(
"p <- plot_richness({glue_collapse(scriptArgs, sep=', ')})"
)
)
if (input$richnessBoxplot >= 2) {
script <- c(script,
"p <- p + geom_boxplot()")
}
if (input$richnessBoxplot <= 2) {
script <- c(script,
"p <- p + geom_point()")
}
script <- c(script, "", "plot(p)")
script <- c(script, "", "# Tables")
script <- c(
script,
glue(
"t <- estimate_richness({glue_collapse(c(\"data\", measures), sep=', ')})"
),
"write.table(t, file = \"richness.tsv\", sep = \"\\t\", col.names = NA)"
)
return(glue_collapse(script, sep = "\n"))
})
output$richnessA <- renderPlot({
validate(need(data16S(),
"Requires an abundance dataset"))
p <- plot_richness(
physeq = data16S(),
x = ifelse(is.null(checkNull(
input$richnessX
)), "samples", input$richnessX),
color = checkNull(input$richnessColor),
shape = checkNull(input$richnessShape),
title = checkNull(input$richnessTitle),
measures = checkNull(input$richnessMeasures)
)
631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700
if (input$richnessBoxplot >= 2) {
p <- p + geom_boxplot()
}
if (input$richnessBoxplot <= 2) {
p <- p + geom_point()
}
return(p)
})
output$richnessATable <- renderUI({
validate(need(data16S(),
"Requires an abundance dataset"))
p(beautifulTable(data.frame(
SAMPLE = sample_names(data16S()), round(estimate_richness(data16S()), digits = 2)
)))
})
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))) {
701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770
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",
771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840
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,
841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910
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$rarefactionCurve <- renderPlot({
validate(need(data16S(),
"Requires an abundance dataset"))
p <- ggrare(
physeq = data16S(),
step = 100,
#step = input$rarefactionStep,
color = checkNull(input$rarefactionColor),
label = checkNull(input$rarefactionLabel),
se = FALSE
)
if (!is.null(checkNull(input$rarefactionGrid))) {
p <- p + facet_grid(paste(".", "~", input$rarefactionGrid))
}
if (input$rarefactionMin) {
p <-
p + geom_vline(xintercept = min(sample_sums(data16S())),
color = "gray60")
}
return(p + ggtitle(input$rarefactionTitle))
})
output$rarefactionCurveUI <- renderUI({
validate(need(data16S(), ""))
box(
title = "Setting : " ,
width = NULL,
status = "primary",
# sliderInput(
# "rarefactionStep",
# label = "Etapes de calcul : ",
# min = 1,
# max = 1000,
# value = 100
# ),
checkboxInput("rarefactionMin", label = "Show min sample threshold", value = FALSE),
textInput("rarefactionTitle",
label = "Title : ",
value = "Rarefaction curves"),
selectInput(
"rarefactionColor",
label = "Color : ",
choices = c("..." = 0, sample_variables(data16S()))
),
selectInput(
"rarefactionLabel",
label = "Label : ",
choices = c("..." = 0, sample_variables(data16S()))
),
selectInput(
"rarefactionGrid",
label = "Subplot : ",
choices = c("..." = 0, sample_variables(data16S()))
),
911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980
collapsedBox(verbatimTextOutput("rarefactionCurveScript"), title = "RCode")
)
})
output$rarefactionCurveScript <- renderText({
scriptArgs <- c("physeq = data",
"step = 100",
"se = FALSE")
if (!is.null(checkNull(input$rarefactionColor))) {
scriptArgs <-
c(scriptArgs,
glue("color = \"{input$rarefactionColor}\""))
}
if (!is.null(checkNull(input$rarefactionLabel))) {
scriptArgs <-
c(scriptArgs,
glue("label = \"{input$rarefactionLabel}\""))
}
script <- c(
scriptHead,
"# Plot rarefaction curves",
glue("p <- ggrare({glue_collapse(scriptArgs, sep=', ')})")
)
if (!is.null(checkNull(input$rarefactionGrid))) {
script <- c(script,
glue("p <- p + facet_grid(\". ~ {input$rarefactionGrid}\")"))
}
if (input$rarefactionMin) {
script = c(
script,
"p <- p + geom_vline(xintercept = min(sample_sums(data)), color = \"gray60\")"
)
}
if (!is.null(checkNull(input$rarefactionTitle))) {
script <- c(script,
glue("p <- p + ggtitle({input$rarefactionTitle})"))
}
script <- c(script, "", "plot(p)")
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",
981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050
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"))
})
1051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120
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(
title = "Setting : " ,
width = NULL,
status = "primary",
radioButtons(
"treeRank",
label = "Taxonomic rank captioned : ",
choices = c(aucun = "",
rank_names(data16S()),
OTU = "taxa_names"),
inline = TRUE
),
sliderInput(
"treeTopOtu",
label = "Show the n most abundant OTU : ",
min = 1,
max = ntaxa(data16S()),
value = 20
),
checkboxInput("treeRadial", label = "Radial tree", value = FALSE),
checkboxInput("treeSample", label = "Show samples", value = TRUE),
textInput("treeTitle",
label = "Title : ",
value = "Phylogenetic tree"),
selectInput(
"treeCol",
label = "Color : ",
choices = c("..." = 0, sample_variables(data16S()))
),
selectInput(
"treeShape",
label = "Shape : ",
choices = c("..." = 0, sample_variables(data16S()))
),
collapsedBox(verbatimTextOutput("treeScript"), title = "RCode")
)
})
output$treeScript <- renderText({
scriptArgs <- c(
glue(
"physeq = prune_taxa(names(sort(taxa_sums(data), decreasing = TRUE)[1:{input$treeTopOtu}]), data)"
)
)
if (input$treeSample) {
1121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190
scriptArgs <- c(scriptArgs, "method = \"sampledodge\"")
} else {
scriptArgs <- c(scriptArgs, "method = \"treeonly\"")
}
if (!is.null(checkNull(input$treeCol))) {
scriptArgs <- c(scriptArgs, glue("color = \"{input$treeCol}\""))
}
if (!is.null(checkNull(input$treeShape))) {
scriptArgs <- c(scriptArgs, glue("shape = \"{input$treeShape}\""))
}
scriptArgs <- c(scriptArgs, "size = \"abundance\"")
if (!is.null(checkNull(input$treeRank))) {
scriptArgs <-
c(scriptArgs, glue("label.tips = \"{input$treeRank}\""))
}
scriptArgs <- c(scriptArgs,
"sizebase = 5",
"ladderize = \"left\"",
"plot.margin = 0")
if (!is.null(checkNull(input$treeTitle))) {
scriptArgs <- c(scriptArgs, glue("title = \"{input$treeTitle}\""))
}
script <- c(
scriptHead,
"# Plot phylogenetic tree",
glue("p <- plot_tree({glue_collapse(scriptArgs, sep=', ')})")
)
if (input$treeRadial) {
script <- c(script,
"p <- p + coord_polar(theta = \"y\")")
}
script <- c(script, "", "plot(p)")
return(glue_collapse(script, sep = "\n"))
})
output$tree <- renderPlot({
validate(
need(data16S(), "Requires an abundance dataset"),
need(
phy_tree(data16S(), errorIfNULL = FALSE),
"Requires a phylogenetic tree"
)
)
p <- plot_tree(
physeq = prune_taxa(names(sort(
taxa_sums(data16S()), decreasing = TRUE
)[1:input$treeTopOtu]), data16S()),
method = ifelse(input$treeSample, "sampledodge", "treeonly"),
color = checkNull(input$treeCol),
shape = checkNull(input$treeShape),
size = "abundance",
label.tips = checkNull(input$treeRank),
sizebase = 5,
ladderize = "left",
plot.margin = 0,
title = checkNull(input$treeTitle)
)
if (checkNull(input$treeRadial)) {
return(p + coord_polar(theta = "y"))
} else {
return(p)
}
})
output$acpUI <- renderUI({
validate(need(data16S(), ""))
box(
title = "Setting : " ,
width = NULL,
1191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260
status = "primary",
checkboxGroupInput(
"acpAxes",
label = "Axes : ",
choices = seq(10),
selected = c(1, 2),
inline = TRUE
),
selectInput(
"acpDist",
label = "Distance : ",
selected = "bray",
choices = list(
"bray",
"jaccard",
"unifrac",
"wunifrac",
"dpcoa",
"jsd",
"euclidean"
)
),
selectInput(
"acpMethod",
label = "Method : ",
selected = "MDS",
choices = list("DCA", "CCA", "RDA", "CAP", "DPCoA", "NMDS", "MDS", "PCoA")
),
textInput("acpTitle",
label = "Title : ",
value = "Samples ordination graphic"),
selectInput(
"acpLabel",
label = "Label : ",
choices = c("..." = 0, sample_variables(data16S()))
),
selectInput(
"acpCol",
label = "Color : ",
choices = c("..." = 0, sample_variables(data16S()))
),
selectInput(
"acpShape",
label = "Shape : ",
choices = c("..." = 0, sample_variables(data16S()))
),
selectInput(
"acpEllipse",
label = "Ellipses : ",
choices = c("..." = 0, sample_variables(data16S()))
),
selectInput(
"acpRep",
label = "Barycenters : ",
choices = c("..." = 0, sample_variables(data16S()))
),
collapsedBox(verbatimTextOutput("acpScript"), title = "RCode")
)
})
output$acpScript <- renderText({
scriptArgs <- c(
"physeq = data",
glue(
"ordination = ordinate(data, method = \"{input$acpMethod}\", distance = \"{input$acpDist}\")"
),
glue("axes = c({glue_collapse(input$acpAxes, sep = ', ')})")
)
if (!is.null(checkNull(input$acpCol))) {
scriptArgs <- c(scriptArgs, glue("color = \"{input$acpCol}\""))
126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323
}
if (!is.null(checkNull(input$acpShape))) {
scriptArgs <- c(scriptArgs, glue("shape = \"{input$acpShape}\""))
}
if (!is.null(checkNull(input$acpRep))) {
scriptArgs <- c(scriptArgs, glue("replicate = \"{input$acpRep}\""))
} else {
scriptArgs <- c(scriptArgs, glue("replicate = NULL"))
}
if (!is.null(checkNull(input$acpLabel))) {
scriptArgs <- c(scriptArgs, glue("label = \"{input$acpLabel}\""))
}
if (!is.null(checkNull(input$acpTitle))) {
scriptArgs <- c(scriptArgs, glue("title = \"{input$acpTitle}\""))
}
script <- c(
scriptHead,
"# MultiDimensional scaling",
glue("p <- plot_samples({glue_collapse(scriptArgs, sep=', ')})")
)
if (!is.null(checkNull(input$acpEllipse))) {
script <- c(
script,
glue(
"p <- p + stat_ellipse(aes_string(group = \"{input$acpEllipse}\"))"
)
)
}
script <- c(script, "", "plot(p + theme_bw())")
return(glue_collapse(script, sep = "\n"))
})
output$acp <- renderPlot({
validate(
need(data16S(), "Requires an abundance dataset"),
need(length(input$acpAxes) == 2, "Requires two projections axes")
)
p <- plot_samples(
data16S(),
ordination = ordinate(
data16S(),
method = input$acpMethod,
distance = input$acpDist
),
axes = as.numeric(input$acpAxes),
title = checkNull(input$acpTitle),
color = checkNull(input$acpCol),
replicate = if (is.null(checkNull(input$acpRep))) {
NULL
} else {
checkNull(input$acpRep)
},
shape = checkNull(input$acpShape),
label = checkNull(input$acpLabel)
)
if (!is.null(checkNull(input$acpEllipse))) {
p <- p + stat_ellipse(aes_string(group = input$acpEllipse))
}
return(p + theme_bw())
})
})