server.R 36.95 KiB
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"))