-
Midoux Cedric authorede9de9648
Forked from
Midoux Cedric / easy16S
122 commits behind the upstream repository.
library(shinydashboard)
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"
)
}
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")
{
## 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)
7172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140
## 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())
})
}
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)")
141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210
})
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.\n Make sure that the phyloseq object in the RData file is called 'data'."
)
)
data16S()
})
output$sampledataTable <- renderUI({
validate(need(sample_data(data16S(), errorIfNULL = FALSE), ""))
box(
title = "Class of sample_data",
width = NULL,
status = "primary",
collapsible = TRUE,
collapsed = TRUE,
renderTable({
(sapply(sample_data(data16S()), class))
}, rownames = TRUE, colnames = FALSE)
)
#sapply(sample_data(data16S()), class)
#}, rownames = TRUE, colnames = FALSE, caption = "Class of sample_data", caption.placement = "top")
})
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()))
))
)
)
})
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",
211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280
label = "Subplot : ",
choices = c("..." = 0, sample_variables(data16S()))
),
selectInput(
"barX",
label = "X : ",
choices = c("..." = 0, sample_variables(data16S()))
),
box(
title = "RCode",
width = NULL,
status = "primary",
collapsible = TRUE,
collapsed = TRUE,
verbatimTextOutput("histScript")
)
)
})
output$histScript <- renderText({
paste0(
"# Loading packages\n",
"source(\"https://raw.githubusercontent.com/mahendra-mariadassou/phyloseq-extended/master/R/load-extra-functions.R\")\n",
"\n",
"# Loading data\n",
paste0(
"load(\"",
paste("Easy16S-data", Sys.Date(), "RData", sep = "."),
"\") # if necessary, adapt the file path\n"
),
"\n",
"# View data\n",
"data\n",
"\n",
"# Plot barplot\n",
"p <- plot_bar(physeq = data",
ifelse(
is.null(checkNull(input$barFill)),
"",
paste0(",\n fill = \"", input$barFill, "\"")
),
ifelse(is.null(checkNull(input$barX)), "", paste0(",\n x = ", input$barX)),
ifelse(
is.null(checkNull(input$barTitle)),
"",
paste0(",\n title = \"", input$barTitle, "\"")
),
")\n",
ifelse(
is.null(checkNull(input$barGrid)),
"",
paste0(
"p <- p + facet_grid(\". ~ ",
input$barGrid,
"\", scales = \"free_x\")\n"
)
),
"\n",
"plot(p)"
)
})
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)
281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350
)
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(), ""))
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())))
})
output$histFocusUIfocusX <- renderUI({
validate(need(data16S(), ""))
selectInput("focusX",
label = "X : ",
choices = c("..." = 0, sample_variables(data16S())))
})
output$histoFocus <- renderPlot({
validate(need(data16S(),
"Requires an abundance dataset"))
p <- plot_composition(
physeq = data16S(),
taxaRank1 = input$focusRank,
taxaSet1 = input$focusTaxa,
taxaRank2 = rank_names(data16S())[which(rank_names(data16S()) == input$focusRank) + 1],
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 <-
351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420
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()))
)
)
})
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",
421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490
"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()))
)
)
})
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)
)
if (input$richnessBoxplot >= 2) {
p <- p + geom_boxplot()
}
if (input$richnessBoxplot <= 2) {
p <- p + geom_point()
}
return(p)
})
491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560
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({
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")
)
})
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
),
561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630
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())
)
)
)
})
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$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
)
631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700
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()))
)
)
})
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 : ",
701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770
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"
)
)
)
})
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(data16S(), ""))
box(
title = "Setting : " ,
width = NULL,
status = "primary",
radioButtons(
"treeRank",
label = "Taxonomic rank captioned : ",
choices = c(aucun = "",
rank_names(data16S()),
771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840
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()))
)
)
})
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,
status = "primary",
checkboxGroupInput(
"acpAxes",
label = "Axes : ",
choices = seq(10),
selected = c(1, 2),
inline = TRUE
),
841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910
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()))
)
)
})
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)
911912913914915916917918919920921
},
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())
})
})