Forked from Midoux Cedric / easy16S
Source project has a limited visibility.
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"))
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()) }) })