An error occurred while loading the file. Please try again.
-
Guillaume Perréal authoreda8cfed21
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"))