R/shiny_modules.R

Defines functions reformatMetadata reformatMetadataui plotViolin plotViolinui plotClustree plotClustree_UI downloadTable downloadTable_UI

Documented in downloadTable downloadTable_UI plotClustree plotClustree_UI plotViolin plotViolinui reformatMetadata reformatMetadataui

#' Title
#'
#' @param id
#'
#' @return
#' @export
#'
#' @examples
downloadTable_UI <- function(id) {
  ns <- NS(id)
  tagList(
    uiOutput(ns("geaDownloadButton"))
    # downloadButton(ns("mydata"), "my data")
  )
}

#' Title
#'
#' @param input
#' @param output
#' @param session
#' @param mytable
#'
#' @return
#' @export
#'
#' @examples
downloadTable <- function(input, output, session, mytable) {
  ns <- session$ns
  results <- reactive({
    req(mytable())
    mytable()$results
  })

  reportLink <- reactive({
    req(mytable())
    mytable()$report
  })

  output$geaDownloadButton <- renderUI({
    req(mytable())
    downloadButton(ns("mydata"), "Gene Enrichment Results")
  })

  # Downloadable csv of selected dataset ----
  output$mydata <- downloadHandler(
    filename = function(){
      paste0(fs::path_file(reportLink()), ".csv")
      },
    content = function(myfile) {
      write.csv(results(), myfile, row.names = FALSE)
    }
  )
}

#' plot clustree ui
#'
#' @param id
#'
#' @return
#' @export
#'
#' @examples
plotClustree_UI <- function(id) {
  ns <- NS(id)
  tagList(
    # textOutput(ns("checkSeu")),
    plotOutput(ns("clustree"))

  )
}

#' plot clustree server
#'
#' @param input
#' @param output
#' @param session
#' @param seu
#'
#' @return
#' @export
#'
#' @examples
plotClustree <- function(input, output, session, seu) {

  output$checkSeu <- renderText({
    req(seu$active)
    "test"
  })

  output$clustree <- renderPlot({
    req(seu$active)
    clustree::clustree(seu$active)
  })

}

#' Plot Violin plots UI
#'
#' @param id
#'
#' @return
#' @export
#'
#' @examples
#'
plotViolinui <- function(id){
  ns <- NS(id)
  tagList(
    uiOutput(ns("vln_split")),
    uiOutput(ns("split_val")),
    uiOutput(ns("vln_group")),
    uiOutput(ns("featuretext")),
    plotOutput(ns("vplot"), height = 750)

  )
}


#' Plot Violin server
#'
#' @param input
#' @param output
#' @param session
#' @param seu
#' @param feature_type
#'
#' @return
#' @export
#'
#' @examples
#'
plotViolin <- function(input, output, session, seu, feature_type){
  ns <- session$ns
  prefill_feature <- reactive({
    if (feature_type() == "transcript") {
      "ENST00000488147"
    }
    else if (feature_type() == "gene") {
      "RXRG"
    }
  })

  output$featuretext <- renderUI({
    textInput(ns("customFeature"), "gene or transcript on which to color the plot; eg. 'RXRG' or 'ENST00000488147'",
              value = prefill_feature())
  })

  output$vln_split <- renderUI({
    req(seu$active)
    selectizeInput(ns("vlnSplit"), "choose variable filter by", choices = colnames(seu$active[[]]), selected = "batch")
  })

  output$split_val <- renderUI({
    req(seu$active)
    req(input$vlnSplit)
    selectizeInput(ns("splitVal"), "choose value to filter by", choices = unique(seu$active[[input$vlnSplit]][,1]))
  })

  output$vln_group <- renderUI({
    req(seu$active)
    selectizeInput(ns("vlnGroup"), "choose variable to group by", choices = colnames(seu$active[[]]), selected = "batch")
  })

  output$vplot <- renderPlot({
    req(input$customFeature)
    req(input$vlnGroup)
    req(input$vlnSplit)

    selected_cells <- as_tibble(seu$active[[input$vlnSplit]], rownames= "sample_id") %>%
      dplyr::filter(!!sym(input$vlnSplit) == input$splitVal) %>%
      dplyr::pull(sample_id)

    sub_seu <- seu$active[,selected_cells]

    plot_violin(sub_seu, plot_var = input$vlnGroup, features = input$customFeature)
  })
}


#' Reformat Seurat Object Metadata UI
#'
#' @param id
#'
#' @return
#' @export
#'
#' @examples
reformatMetadataui <- function(id) {
  ns <- NS(id)
  tagList(
    box(
    uiOutput(ns("colNames")),
    textInput(ns("newCol"), "provide a name for the new column"),
    actionButton(ns("mergeCol"), "Merge Selected Columns"),
    checkboxInput(ns("header"), "Header", TRUE),
    fileInput(ns("addCols"), "Choose CSV File of metadata with cell names in first column",
              accept = c(
                "text/csv",
                "text/comma-separated-values,text/plain",
                ".csv")
    ),
    DTOutput(ns("seuTable")),
    width = 12
    )

  )
}

#' Reformat Seurat Object Metadata Server
#'
#' @param input
#' @param output
#' @param sessionk
#' @param seu
#'
#' @return
#' @export
#'
#' @examples
reformatMetadata <- function(input, output, session, seu) {
  ns <- session$ns

  meta <- reactiveValues()

  observe({
    # req(seu$active)
    meta$old <- data.frame(seu$active[[]]) %>%
      identity()

    # na_cols <- purrr::map_lgl(meta$old, ~all(is.na(.x)))
    # cluster_cols <- grepl("^cluster|snn_res", colnames(meta$old))
    #
    # keep_cols <- !(na_cols | cluster_cols)
    #
    # meta$old <- meta$old[,keep_cols]
  })

  seuColNames <- reactive({
    seuColNames <- colnames(seu$gene[[]]) %>%
      purrr::set_names(.)
  })

  output$colNames <- renderUI({
    selectizeInput(ns("col_names"), "Seurat Object Metdata Columns", choices = seuColNames(), multiple = TRUE)
  })

  observeEvent(input$mergeCol, {

    combined_cols <- combine_cols(seu, input$col_names, input$newCol)
    meta$new <- combined_cols

    for (i in names(seu)){
      seu[[i]] <- Seurat::AddMetaData(seu[[i]], meta$new)
    }

    meta$old <- cbind(meta$old, meta$new)

  })

  observeEvent(input$addCols, {

    inFile <- input$addCols

    if (is.null(inFile))
      return(NULL)

    meta$new <- read.csv(inFile$datapath, header = input$header, row.names = 1)

    for (i in names(seu)){
      seu[[i]] <- Seurat::AddMetaData(seu[[i]], meta$new)
      print(colnames(seu[[i]][[]]))
    }

    meta$old <- cbind(meta$old, meta$new)

  })

  output$seuTable <- renderDT({
    # req(meta$old)

    DT::datatable(meta$old, extensions = 'Buttons', options = list(dom = "Bft", buttons = c("copy", "csv"),
                                                                  scrollX = "100px", scrollY = "800px"))


  })

  return(seu)

}


#' Integrate Project UI
#'
#' @param id
#'
#' @return
#' @export
#'
#' @examples
integrateProjui <- function(id){
    ns <- NS(id)
    tagList(
      box(
        actionButton(ns("integrateAction"), "Integrate Selected Projects"),
        DT::dataTableOutput(ns("myDatatable"))
        ),
      box(
        textOutput(ns("integrationComplete")),
        shinyjs::useShinyjs(),
        textOutput(ns("integrationMessages")),
        textOutput(ns("integrationResult")),
        shinyFiles::shinySaveButton(ns("saveIntegratedProject"), "Save Integrated Project", "Save project as...")
      )
      )
    }

#' Integrate Projects Server Function
#'
#' @param input
#' @param output
#' @param proj_matrices
#' @param session
#'
#' @return
#' @export
#'
#' @examples
integrateProj <- function(input, output, session, proj_matrices, seu, proj_dir){
    ns <- session$ns

    proj_matrix <- reactive({
      proj_matrices()$primary_projects
    })

    clean_proj_matrix <- reactive({


      clean_proj_matrix <- proj_matrix() %>%
        dplyr::select(-project_path) %>%
        identity()
    })



    output$myDatatable <- DT::renderDataTable(clean_proj_matrix(),
                                              server = FALSE,
                                              rownames=TRUE)

    selectedRows <- eventReactive(input$integrateAction, {
      ids <- input$myDatatable_rows_selected
    })

    selectedProjects <- reactive({
      selectedProjects <- dplyr::slice(proj_matrix(), selectedRows()) %>%
        dplyr::pull(project_path) %>%
        identity()
    })

    mergedSeus <- reactiveVal()

    observeEvent(input$integrateAction, {
      req(selectedProjects())
          withCallingHandlers({
            shinyjs::html("integrationMessages", "")
            message("Beginning")

            # check if seurat paths exist

            # validate(
            #   need(input$data != "", "Please select a data set")
            # )

            mergedSeus(integration_workflow(selectedProjects()))

            message("Integration Complete!")

          },
          message = function(m) {
            shinyjs::html(id = "integrationMessages", html = paste0("Running Integration: ", m$message), add = FALSE)
          })
      })

    newProjDir <- reactive({
      req(mergedSeus())

      print(names(mergedSeus()))

      for (i in names(mergedSeus())){
        seu[[i]] <- mergedSeus()[[i]]
      }

      newProjName <- paste0(purrr::map(fs::path_file(selectedProjects()), ~gsub("_proj", "", .x)), collapse = "_")
      newProjName <- paste0(newProjName, "_proj")
      integrated_proj_dir <- "/dataVolume/storage/single_cell_projects/integrated_projects/"
      newProjDir <- fs::path(integrated_proj_dir, newProjName)

      proj_dir(newProjDir)

      newProjDir

    })

    output$integrationComplete <- renderText({
      req(mergedSeus())
      # print("integration complete!")
      print("")
    })


    volumes <- reactive({
      volumes <- c(Home = fs::path("/dataVolume/storage/single_cell_projects/integrated_projects"), "R Installation" = R.home(), shinyFiles::getVolumes())
      # print(volumes)
      volumes
    })

    observe({
      shinyFiles::shinyFileSave(input, "saveIntegratedProject", roots = volumes(), session = session, restrictions = system.file(package = "base"))
    })


    integratedProjectSavePath <- eventReactive(input$saveIntegratedProject, {
      savefile <- shinyFiles::parseSavePath(volumes(), input$saveIntegratedProject)

      savefile$datapath
    })

    output$integrationResult <- renderText({
      integratedProjectSavePath()
    })

    observeEvent(input$saveIntegratedProject, {
      req(mergedSeus())
      req(integratedProjectSavePath())

      if (!is.null(integratedProjectSavePath())){

        shiny::withProgress(
          message = paste0("Saving Integrated Dataset to ", integratedProjectSavePath()),
          value = 0,
          {
            # Sys.sleep(6)
            shiny::incProgress(2/10)
            # myseuratdir <- fs::path(paste0(integratedProjectSavePath(), "_proj"), "output", "seurat")
            # dir.create(myseuratdir)
            # myseuratpath <- fs::path(myseuratdir, "unfiltered_seu.rds")
            # saveRDS(mergedSeus(), myseuratpath)
            # Sys.chmod(myseuratpath)
            save_seurat(mergedSeus(), proj_dir = paste0(integratedProjectSavePath(), "_proj"))
            set_permissions_call <- paste0("chmod -R 775 ", integratedProjectSavePath(), "_proj")
            # print(set_permissions_call)
            system(set_permissions_call)
            shiny::incProgress(8/10)
          })

      }

    })


    return(integratedProjectSavePath)

}


#' Change Embedding Parameters UI
#'
#' @param id
#'
#' @return
#' @export
#'
#' @examples
changeEmbedParamsui <- function(id){
  ns <- NS(id)

  minDist_vals <- prep_slider_values(0.3)
  negsamprate_vals <- prep_slider_values(5)

  tagList(
    selectizeInput(ns("dims"), label = "Dimensions from PCA", choices = seq(1,99), multiple = TRUE, selected = 1:30),
    sliderInput(ns("minDist"), label = "Minimum Distance", min = minDist_vals$min, max = minDist_vals$max, value = minDist_vals$value, step = minDist_vals$step),
    sliderInput(ns("negativeSampleRate"), label = "Negative Sample Rate", min = negsamprate_vals$min, max = negsamprate_vals$max, value = negsamprate_vals$value, step = negsamprate_vals$step)
  )
}

#' Change Embedding Parameters
#'
#' @param input
#' @param output
#' @param session
#' @param seu
#'
#' @return
#' @export
#'
#' @examples
changeEmbedParams <- function(input, output, session, seu){
  ns <- session$ns
  #
  # output$embedControls <- renderUI({
  #   tagList(
  #     sliderInput(ns("minDist"), label = "Minimum Distance", min = minDist_vals$min, max = minDist_vals$max, value = minDist_vals$value, step = minDist_vals$step),
  #     sliderInput(ns("negativeSampleRate"), label = "NegativeSampleRate", min = minDist_vals$min, max = minDist_vals$max, value = minDist_vals$value, step = minDist_vals$step)
  #   )
  # })

  seu$gene <- RunUMAP(seu$gene, dims = as.numeric(input$dims), reduction = "pca", min.dist = input$minDist, negative.sample.rate = input$negativeSampleRate)
  seu$transcript <- RunUMAP(seu$transcript, dims = as.numeric(input$dims), reduction = "pca", min.dist = input$minDist, negative.sample.rate = input$negativeSampleRate)
  seu$active <- seu$gene


  return(seu)

}

#' Plot Dimensionally Reduced Data UI
#'
#' @param id
#'
#' @return
#' @export
#'
#' @examples
plotDimRedui <- function(id) {
  ns <- NS(id)
  tagList(
    uiOutput(ns("dplottype")),
    shinyWidgets::prettyRadioButtons(ns("embedding"),
      "dimensional reduction method",
      choices = c("pca", "harmony", "tsne", "umap"), selected = "umap", inline = TRUE
    ),
    fluidRow(
      column(2, selectizeInput(ns("dim1"), "Dimension 1", choices = seq(1,99), selected = 1)),
      column(2, selectizeInput(ns("dim2"), "Dimension 2", choices = seq(1,99), selected = 2))
    ),
    uiOutput(ns("featuretext")),
    sliderInput(ns("resolution"), "Resolution of clustering algorithm (affects number of clusters)", min = 0.2, max = 2, step = 0.2, value = 0.6),
    plotly::plotlyOutput(ns("dplot"), height = 750)
  )
}

#' Plot Dimensionally Reduced Data
#'
#' @param input
#' @param output
#' @param session
#' @param seu
#' @param plot_types
#' @param featureType
#' @param organism_type
#'
#' @return
#' @export
#'
#' @examples
plotDimRed <- function(input, output, session, seu, plot_types, featureType, organism_type) {
  ns <- session$ns

  selected_plot <- reactiveVal()

  output$dplottype <- renderUI({
    req(seu$active)

    selected_plot <- ifelse(is.null(selected_plot()), "custom", selected_plot())

    selectizeInput(ns("plottype"), "Variable to Plot",
                   choices = purrr::flatten_chr(plot_types()), selected = selected_plot, multiple = TRUE)
  })

  prefill_feature <- reactive({
    if (featureType() == "transcript") {
      if (organism_type() == "human"){
        "ENST00000488147"
      } else if (organism_type() == "mouse"){
        "ENSG00000488147"
      }

    } else if (featureType() == "gene") {
      if (organism_type() == "human"){
        "RXRG"
      } else if (organism_type() == "mouse"){
        "Rxrg"
      }
    }
  })
  output$featuretext <- renderUI({
    textInput(ns("customFeature"), "gene or transcript on which to color the plot; eg. 'RXRG' or 'ENST00000488147'",
              value = prefill_feature())
  })

  output$dplot <- plotly::renderPlotly({
    req(input$plottype)
    req(seu$active)
    req(input$customFeature)

    if (length(input$plottype) > 1) {
      mycols = input$plottype

      louvain_resolution = paste0(DefaultAssay(seu$active), "_snn_res.", input$resolution)
      leiden_resolution = paste0("leiden_clusters_", input$resolution)
      mycols <- gsub("^seurat$", louvain_resolution,
                     mycols)

      newcolname = paste(mycols, collapse = "_")
      newdata = as_tibble(seu$active[[mycols]], rownames = "Sample_ID") %>%
        tidyr::unite(!!newcolname, mycols) %>% deframe() %>%
        identity()
      seu$active <- AddMetaData(seu$active, metadata = newdata,
                         col.name = newcolname)

      selected_plot(newcolname)

      plot_var(seu$active, dims = c(input$dim1, input$dim2), embedding = input$embedding,
               group = newcolname)
    }
    else {
      if (input$plottype == "custom") {
        plot_feature(seu$active, dims = c(input$dim1, input$dim2), embedding = input$embedding,
                     features = input$customFeature)
      }
      else if (input$plottype %in% plot_types()$continuous_vars) {
        plot_feature(seu$active, dims = c(input$dim1, input$dim2), embedding = input$embedding,
                     features = input$plottype)
      }
      else if (input$plottype == "seurat") {

        if ("integrated" %in% names(seu$active@assays)){
          active_assay <- "integrated"
        } else {
          active_assay <- "RNA"
        }

        louvain_resolution = paste0(active_assay, "_snn_res.", input$resolution)
        plot_var(seu$active, dims = c(input$dim1, input$dim2), embedding = input$embedding,
                 group = louvain_resolution)
      }
      else if (input$plottype == "leiden") {
        leiden_resolution = paste0("leiden_clusters_", input$resolution)
        plot_var(seu$active, dims = c(input$dim1, input$dim2), embedding = input$embedding,
                 group = leiden_resolution)
      }
      else if (input$plottype %in% plot_types()$category_vars) {
        plot_var(seu$active, dims = c(input$dim1, input$dim2), embedding = input$embedding,
                 group = input$plottype)
      }
    }

    # if ("integrated" %in% names([email protected])){
    #   DefaultAssay(seu$active) <- "RNA"
    # }

  })
}

#' Create Table of Selected Cells UI
#'
#' @param id
#'
#' @return
#' @export
#'
#' @examples
tableSelectedui <- function(id) {
  ns <- NS(id)
  tagList(DT::DTOutput(ns("brushtable")))
}

#' Create Table of Selected Cells
#'
#' @param input
#' @param output
#' @param session
#' @param seu
#'
#' @return
#' @export
#'
#' @examples
tableSelected <- function(input, output, session, seu) {
  ns <- session$ns
  brush <- reactive({
    req(seu$active)
    d <- plotly::event_data("plotly_selected")
    if (is.null(d)) {
      msg <- "Click and drag events (i.e. select/lasso) appear here (double-click to clear)"
      return(d)
    }
    else {
      selected_cells <- colnames(seu$active)[as.numeric(d$key)]
    }
  })
  output$brushtable <- DT::renderDT({
    req(seu$active)
    req(brush())
    selected_meta <- data.frame(seu$active[[]][brush(),])

    # selection = list(mode = 'multiple', selected = c(1, 3, 8), target = 'row'),
    DT::datatable(selected_meta, extensions = "Buttons",
                  selection = list(mode = 'multiple', selected = 1:nrow(selected_meta), target = 'row'),
                  options = list(dom = "Bft", buttons = c("copy", "csv"), scrollX = "100px", scrollY = "800px"))
  })

  selected_cells <- reactive({
    selected_rows <- input$brushtable_rows_selected
    rownames(seu$active[[]][brush(),])[selected_rows]
  })

  return(selected_cells)
}


# subsetSeuratui <- function(id) {
#   ns <- NS(id)
#   tagList()
# }
#
#
# subsetSeurat <- function(input, output, session, seu, selected_rows) {
#   ns <- session$ns
#   sub_seu <- reactive({
#     showModal(modalDialog(title = "Subsetting and Recalculating Embeddings",
#                           "This process may take a minute or two!"))
#     seu$gene <- seu$gene[, selected_rows()]
#     seu$gene <- seuratTools::seurat_pipeline(seu$gene, resolution = seq(0.6, 2, by = 0.2))
#     seu$transcript <- seu$transcript[, selected_rows()]
#
#     seu$transcript <- seuratTools::seurat_pipeline(seu$transcript, resolution = seq(0.6, 2, by = 0.2))
#     seu$active <- seu$gene
#     removeModal()
#   })
#   return(sub_seu)
# }


#' Differential Expression UI
#'
#' @param id
#'
#' @return
#' @export
#'
#' @examples
diffexui <- function(id) {
  ns <- NS(id)
  tagList(box(shinyWidgets::prettyRadioButtons(ns("diffex_scheme"),
    "Cells to Compare",
    choiceNames = c(
      "Seurat Cluster",
      "Custom"
    ), choiceValues = c("seurat", "custom"),
    selected = "seurat"
  ), conditionalPanel(
    ns = ns,
    condition = "input.diffex_scheme == 'seurat'",
    sliderInput(ns("seuratResolution"), "Resolution of clustering algorithm (affects number of clusters)",
      min = 0.2, max = 2, step = 0.2, value = 0.6
    ),
    numericInput(ns("cluster1"),
      "first cluster to compare",
      value = 0
    ), numericInput(ns("cluster2"),
      "second cluster to compare",
      value = 1
    )
  ), conditionalPanel(
    ns = ns,
    condition = "input.diffex_scheme == 'custom'",
    sliderInput(ns("customResolution"), "Resolution of clustering algorithm (affects number of clusters)",
      min = 0.2, max = 2, step = 0.2, value = 0.6
    ),
    shinyWidgets::actionBttn(
      ns("saveClust1"),
      "Save to Custom Cluster 1"
    ), shinyWidgets::actionBttn(
      ns("saveClust2"),
      "Save to Custom Cluster 2"
    )
  ), uiOutput(ns("testChoices")),
  shinyWidgets::actionBttn(
    ns("diffex"),
    "Run Differential Expression"
  ),
  downloadLink(ns("downloadData"), "Download Complete DE Results"),
  DT::dataTableOutput(ns("DT1")),
  width = 12
  ), box(
    title = "Custom Cluster 1", DT::DTOutput(ns("cc1")),
    width = 12
  ), box(
    title = "Custom Cluster 2", DT::DTOutput(ns("cc2")),
    width = 12
  ))

}

#' Title
#'
#' @param input
#'
#' @return
#' @export
#'
#' @examples
cells_selected <- function(input) {
  if (identical(input, character(0))) {
    "Please selected desired cells by clicking on the table"
  } else {
    NULL
  }
}

#' Differential Expression
#'
#' @param input
#' @param output
#' @param session
#' @param seu
#' @param featureType
#' @param selected_cells
#' @param tests
#'
#' @return
#' @export
#'
#' @examples
diffex <- function(input, output, session, seu, featureType, selected_cells, tests = c("t-test" = "t", "wilcoxon rank-sum test" = "wilcox", "Likelihood-ratio test (bimodal)" = "bimod", "MAST" = "MAST")) {
  ns <- session$ns

  output$testChoices <- renderUI(
    shinyWidgets::prettyRadioButtons(ns("diffex_method"),
                                     "Method of Differential Expression",
                                     choices = tests
    )

  )

  brush <- reactive({
    req(seu$active)
    d <- plotly::event_data("plotly_selected")
    if (is.null(d)) {
      msg <- "Click and drag events (i.e. select/lasso) appear here (double-click to clear)"
      return(d)
    }
    else {
      selected_cells <- colnames(seu$active)[as.numeric(d$key)]
    }
  })
  custom_cluster1 <- eventReactive(input$saveClust1,
                                   {
                                     validate(
                                       cells_selected(selected_cells())
                                     )
                                     isolate(selected_cells())
                                   })
  custom_cluster2 <- eventReactive(input$saveClust2,
                                   {
                                     validate(
                                       cells_selected(selected_cells())
                                     )
                                     isolate(selected_cells())
                                   })

  output$cc1 <- DT::renderDT({
    req(custom_cluster1())
    selected_meta <- data.frame(seu$active[[]][custom_cluster1(),
                                               ])
    DT::datatable(selected_meta, extensions = "Buttons",
                  options = list(dom = "Bft", buttons = c("copy",
                                                          "csv"), scrollX = "100px", scrollY = "400px"))
  })
  output$cc2 <- DT::renderDT({
    req(custom_cluster2())
    selected_meta <- data.frame(seu$active[[]][custom_cluster2(),
                                               ])
    DT::datatable(selected_meta, extensions = "Buttons",
                  options = list(dom = "Bft", buttons = c("copy",
                                                          "csv"), scrollX = "100px", scrollY = "400px"))
  })

  de_results <- eventReactive(input$diffex, {

    if (input$diffex_scheme == "seurat") {
      run_seurat_de(seu$active, input$cluster1, input$cluster2,
                    resolution = input$seuratResolution, diffex_scheme = "seurat", featureType, tests = tests)
    }

    else if (input$diffex_scheme == "custom") {
      cluster1 <- unlist(strsplit(custom_cluster1(),
                                  " "))
      cluster2 <- unlist(strsplit(custom_cluster2(),
                                  " "))
      run_seurat_de(seu$active, cluster1, cluster2,
                    input$customResolution, diffex_scheme = "custom", featureType, tests = tests)
    }
  })

  output$DT1 <- DT::renderDT(de_results()[[input$diffex_method]],
                             extensions = "Buttons", options = list(dom = "Bfptr",
                                                                    buttons = c("copy", "csv"), scrollX = "100px", pageLength = 20, paging = FALSE), class = "display")

  cluster_list <- reactive({
    if (input$diffex_scheme == "seurat"){
      seu_meta <- seu$active[[paste0(DefaultAssay(seu$active), "_snn_res.", input$seuratResolution)]]
      cluster1_cells <- rownames(seu_meta[seu_meta == input$cluster1, , drop = FALSE])
      cluster2_cells <- rownames(seu_meta[seu_meta == input$cluster2, , drop = FALSE])
      list(cluster1 = cluster1_cells, cluster2 = cluster2_cells)
    } else if (input$diffex_scheme == "custom"){
      list(cluster1 = custom_cluster1(), cluster2 = custom_cluster2())
    }

  })

  return(list(cluster_list = cluster_list, de_results = de_results))

}

#' Gene Enrichment UI
#'
#' @param id
#'
#' @return
#' @export
#'
#' @examples
geneEnrichmentui <- function(id){
  ns <- NS(id)
  tagList(
    fluidRow(
      box(
        actionButton(ns("enrichmentAction"), "Run Enrichment Analysis"),
        textOutput(ns("enrichmentMessages")),
        radioButtons(ns("enrichmentMethod"), "Enrichment Method to Use:",
                     c("Gene Set Enrichment Analysis" = "gsea",
                       "GO Over-representation Analysis" = "ora",
                       "GO Network Analysis" = "nbea"),
                     selected = c("ora")),
      ),
      box(
        fileInput(ns("uploadDiffex"), "Choose CSV File Differential Expression Results",
                  accept = c(
                    "text/csv",
                    "text/comma-separated-values,text/plain",
                    ".csv")
        )
      )
    ),
    htmlOutput(ns("map"))
  )

}


#' Gene Enrichment
#'
#' @param input
#' @param output
#' @param session
#' @param seu
#' @param diffex_clusters
#'
#' @return
#' @export
#'
#' @examples
geneEnrichment <- function(input, output, session, seu, diffex_results){
    ns <- session$ns

    observeEvent(input$uploadDiffex, {

      inFile <- input$addCols

      if (is.null(inFile))
        return(NULL)

      # meta$new <- read.csv(inFile$datapath, header = input$header, row.names = 1)

    })

    enrichmentReport <- eventReactive(input$enrichmentAction, {
      withCallingHandlers({
        shinyjs::html("enrichmentMessages", "")
        message("Beginning")

        # showModal(modalDialog("Calculating Functional Enrichment", footer=NULL))
        enrichmentReport <- run_enrichmentbrowser(seu = seu$active,
                              cluster_list = diffex_results$cluster_list(),
                              de_results = diffex_results$de_results(),
                              enrichment_method = input$enrichmentMethod)

        # enrichmentReport <- "enrichmentbrowser2/mainpage.html"
        # removeModal()

        # zip::zipr("test.zip", "enrichmentreport")

        return(enrichmentReport)

    },
      message = function(m) {
        shinyjs::html(id = "enrichmentMessages", html = paste0("Running Functional Enrichment Analysis: ", m$message), add = FALSE)
      })
    })

    output$reportLink <- renderUI({
      tags$a("Results of Functional Enrichment Analysis", target = "_blank", href = enrichmentReport()$report)
    })

    output$map <- renderUI({
      tags$iframe(seamless="seamless", src= enrichmentReport()$report, width=1000, height=800)
    })

    return(enrichmentReport)


}


#' Find Markers UI
#'
#' @param id
#'
#' @return
#' @export
#'
#' @examples
findMarkersui <- function(id) {
  ns <- NS(id)
  tagList(
      sliderInput(ns("resolution2"), label = "Resolution of clustering algorithm (affects number of clusters)", min = 0.2, max = 2, step = 0.2, value = 0.6),
      numericInput(ns("num_markers"), "Select Number of Markers to Plot for Each Cluster", value = 5, min = 2, max = 20),
      # actionButton(ns("plotDots"), "Plot Markers!"),
      plotly::plotlyOutput(ns("markerplot"), height = 800)
  )
}

#' Find Markers
#'
#' @param input
#' @param output
#' @param session
#' @param seu
#'
#' @return
#' @export
#'
#' @examples
#'
findMarkers <- function(input, output, session, seu) {
  ns <- session$ns

  resolution <- reactive({
    if ("integrated" %in% names(seu$active@assays)){
      active_assay <- "integrated"
    } else {
      active_assay <- "RNA"
    }
    paste0(active_assay, "_snn_res.", input$resolution2)

    })

  output$markerplot <- plotly::renderPlotly({
    plot_markers(seu = seu$active, resolution = resolution(), num_markers = input$num_markers)
  })
}

#' Plot Read Count UI
#'
#' @param id
#' @param plot_types
#'
#' @return
#' @export
#'
#' @examples
plotReadCountui <- function(id) {
  ns <- NS(id)
  tagList(
    uiOutput(ns("rcplottype")),
    sliderInput(ns("resolution"), "Resolution of clustering algorithm (affects number of clusters)",
      min = 0.2, max = 2, step = 0.2, value = 0.6
    ),
    plotly::plotlyOutput(ns("rcplot"), height = 750)
  )
}

#' Plot Read Count
#'
#' @param input
#' @param output
#' @param session
#' @param seu
#' @param plot_types
#'
#' @return
#' @export
#'
#' @examples
plotReadCount <- function(input, output, session, seu, plot_types) {
  ns <- session$ns

  output$rcplottype <- renderUI({
    req(seu$active)
    shiny::selectInput(ns("plottype"), "Variable to Plot",
                       choices = purrr::flatten_chr(plot_types()), selected = c("seurat"), multiple = TRUE
    )
  })

  output$rcplot <- plotly::renderPlotly({
    req(seu$active)
    req(input$plottype)

    if (input$plottype == "seurat") {

      if ("integrated" %in% names(seu$active@assays)){
        active_assay <- "integrated"
      } else {
        active_assay <- "RNA"
      }

      louvain_resolution = paste0(active_assay, "_snn_res.", input$resolution)
      plot_readcount(seu$active, louvain_resolution)
    }
    else if (input$plottype %in% purrr::flatten_chr(plot_types())) {
      plot_readcount(seu$active, input$plottype)
    }
  })
}

#' Cell Cycle Score UI
#'
#' @param id
#'
#' @return
#' @export
#'
#' @examples
ccScoreui <- function(id) {
  ns <- NS(id)
  tagList()
}

#' Cell Cycle Score
#'
#' @param input
#' @param output
#' @param session
#'
#' @return
#' @export
#'
#' @examples
ccScore <- function(input, output, session) {
  ns <- session$ns
  output$rplot1 <- renderPlot({
    req(seu$active)
    plot_ridge(seu$active, features = input$feature)
  })
  plotOutput("rplot1", height = 750)
}

#' Plot All Transcripts UI
#'
#' @param id
#'
#' @return
#' @export
#'
#' @examples
allTranscriptsui <- function(id) {
  ns <- NS(id)
  tagList(fluidRow(box(textInput(ns("feature"), "gene on which to color the plot; eg. 'RXRG'"),
                       # uiOutput(ns("outfile")),
                       # uiOutput(ns("downloadPlot")),
                       width = 12)), fluidRow(uiOutput(ns("plotlys"))))
}

#' Plot All Transcripts
#'
#' @param input
#' @param output
#' @param session
#' @param seu
#' @param featureType
#'
#' @return
#' @export
#'
#' @examples
allTranscripts <- function(input, output, session, seu,
                           featureType, organism_type) {
  ns <- session$ns
  transcripts <- reactiveValues()
  transcripts <- reactive({
    req(featureType())
    req(organism_type())
    req(input$feature)
    req(seu)
    transcripts <- get_transcripts_from_seu(seu, input$feature, organism = organism_type())

  })

  pList <- reactive({
    req(seu$active)

    if(featureType() == "gene"){
      # browser()
      transcript_cols <- as.data.frame(t(as.matrix(seu$transcript[["RNA"]][transcripts(),])))

      cells <- rownames(transcript_cols)
      transcript_cols <- as.list(transcript_cols) %>%
        purrr::map(~purrr::set_names(.x, cells))

      seu$gene[[transcripts()]] <- transcript_cols

      pList <- purrr::map(transcripts(), ~plot_feature(seu$gene,
                                                       embedding = input$embedding, features = .x))
      names(pList) <- transcripts()

    } else if (featureType() == "transcript"){
      pList <- purrr::map(transcripts(), ~plot_feature(seu$transcript,
                                                       embedding = input$embedding, features = .x))
      names(pList) <- transcripts()
    }
    return(pList)
  })

  output$plotlys <- renderUI({

    # result <- vector("list", n)

    plot_output_list <- purrr::map(names(pList()), ~plotly::plotlyOutput(ns(.x), height = 750))


    #   plot_output_list <- lapply(1:length(pList()), function(i) {
    #     plotname <- transcripts()[[i]]
    #     plotly::plotlyOutput(ns(plotname), height = 750)
    #   })
    do.call(tagList, plot_output_list)
  })

  observe({
    # browser()
    for (i in 1:length(pList())) {
      local({
        my_i <- i
        plotname <- transcripts()[[my_i]]
        output[[plotname]] <- plotly::renderPlotly({
          pList()[[my_i]]
        })
      })
    }

  })

  output$outfile <- renderUI({
    req(pList())
    textInput(ns("outfile"), "a descriptive name for the output file",
              value = paste0(input$feature, "_transcripts", "_clustered_by_", featureType(), ".pdf"))
  })

  output$plots <-
    downloadHandler(filename = function() {
      input$outfile
    },
    content = function(file) {
      pdf(file)
      lapply(pList(), print)
      dev.off()
  })

  output$downloadPlot <- downloadHandler(
    filename = function() { paste(input$dataset, '.png', sep='') },
    content = function(file) {
      png(file)
      print(plotInput())
      dev.off()
    })


  output$downloadPlot <- renderUI({
    req(pList())
    downloadButton(ns("plots"), label = "Download plots")
  })
}

#' RNA Velocity UI
#'
#' @param id
#'
#' @return
#' @export
#'
#' @examples
rnaVelocityui <- function(id){
  ns <- NS(id)
  tagList(
    shinyWidgets::prettyRadioButtons(ns("embedding"), "dimensional reduction method", choices = c("pca", "tsne", "umap"), selected = "umap", inline = TRUE),
    sliderInput(ns("resolution"), "Resolution of clustering algorithm (affects number of clusters)", min = 0.2, max = 2, step = 0.2, value = 0.6),
    plotOutput(ns("vel_plot"), height = "800px")
  )
}

#' RNA Velocity
#'
#' @param input
#' @param output
#' @param session
#' @param seu
#' @param featureType
#' @param format
#'
#' @return
#' @export
#'
#' @examples
rnaVelocity <- function(input, output, session, seu, featureType, format = "grid"){
  ns <- session$ns
  output$vel_plot <- renderPlot({
    req(seu$active)

    showModal(modalDialog("Loading Plots", footer=NULL))
    vel <- seu$active@misc$vel
    emb <- Embeddings(seu$active, reduction = input$embedding)

    louvain_resolution = paste0(DefaultAssay(seu$active), "_snn_res.", input$resolution)

    cell.colors <- as_tibble(seu$active[[louvain_resolution]], rownames = "cellid") %>%
      tibble::deframe() %>%
      as.factor()

    levels(cell.colors) <- scales::hue_pal()(length(levels(cell.colors)))

    plot_velocity(vel, emb, cell.colors, format = format)
    removeModal()
  })
}


#' Title
#'
#' @param id
#'
#' @return
#' @export
#'
#' @examples
monocleui <- function(id){
    ns <- NS(id)
    tagList(
      fluidRow(
        box(
          # sliderInput(ns("resolution"), "Resolution of clustering algorithm (affects number of clusters)", min = 0.2, max = 2, step = 0.2, value = 0.6),
          shinycssloaders::withSpinner(plotlyOutput(ns("monoclePlot"))),
          width = 6
        ),
        box(
          uiOutput(ns("rootCellsui")),
          actionButton(ns("plotPseudotime"), "Calculate Pseudotime With Root Cells"),
          plotOutput(ns("ptimePlot")),
          width = 6
        )
      ),
      fluidRow(
        box(actionButton(ns("calcPtimeGenes"), "Find Pseudotime Correlated Genes"),
            uiOutput(ns("partitionSelect")),
            uiOutput(ns("genePlotQuery2")),
            uiOutput(ns("ptimeGenes")),
            width = 12
            )
      )
      )
}

#' Title
#'
#' @param input
#' @param output
#' @param session
#' @param cds
#' @param seu
#' @param input_type
#' @param resolution
#'
#' @return
#' @export
#'
#' @examples
monocle <- function(input, output, session, cds, seu, input_type, resolution){
    ns <- session$ns

    output$monoclePlot <- renderPlotly({
      req(cds$traj)

      plot_cds(cds$traj, resolution = resolution())
    })

    output$rootCellsui <- renderUI({
      selectizeInput(ns("rootCells"), "Choose Root Cells", choices = c("Choose Root Cells" = "", colnames(cds$traj)), multiple = TRUE)
    })

    observeEvent(input$plotPseudotime, {

      req(cds$traj)

      cds$ptime <- monocle3::order_cells(cds$traj, root_cells = input$rootCells)

      # plot_pseudotime(cds$ptime, color_cells_by = "pseudotime", resolution = input$resolution)

    })

    output$ptimePlot <- renderPlot({
      req(cds$ptime)
      plot_pseudotime(cds$ptime, color_cells_by = "pseudotime", resolution = resolution())

    })



    observeEvent(input$calcPtimeGenes, {
      req(cds$ptime)
      showModal(modalDialog(
        title = "Calculating features that vary over pseudotime",
        "This process may take a minute or two!"
      ))

      cds_pr_test_res = monocle3::graph_test(cds$ptime, neighbor_graph="principal_graph", cores=4)
      removeModal()

      cds$ptime@metadata[["diff_genes"]] <- cds_pr_test_res
      cds$diff_genes <- cds$ptime

    })

    observe({
      req(cds$diff_genes)

      cds_pr_test_res <- cds$diff_genes@metadata$diff_genes
      pr_deg_ids = row.names(subset(cds_pr_test_res, q_value < 0.05))

      output$genePlotQuery1 <- renderPlot({
        req(cds$diff_genes)

        gene_ptime_plot <- monocle3::plot_cells(cds$ptime, genes=pr_deg_ids,
                                                show_trajectory_graph=FALSE,
                                                label_cell_groups=FALSE,
                                                label_leaves=FALSE)

        print(gene_ptime_plot)


      })

      output$genePlotQuery2 <- renderUI({
        selectizeInput(ns("genePlotQuery1"), "Pick Gene to Plot on Pseudotime", choices = pr_deg_ids, multiple = TRUE, selected = pr_deg_ids[1])
      })

      output$ptimeGenesRedPlot <- renderPlot({

        gene_ptime_plot <- monocle3::plot_cells(cds$ptime, genes=input$genePlotQuery1,
                                                show_trajectory_graph=FALSE,
                                                label_cell_groups=FALSE,
                                                label_leaves=FALSE)

        print(gene_ptime_plot)


      })

      available_partitions <- levels(monocle3::partitions(cds$ptime))

      output$partitionSelect <- renderUI({
        selectizeInput(ns("partitions"), "Select a Partition to Plot", choices = available_partitions, multiple = FALSE, selected = available_partitions[1])
      })

      output$ptimeGenesLinePlot <- renderPlot({

        partition_cells <- monocle3::partitions(cds$ptime)
        partition_cells = split(names(partition_cells), partition_cells)
        partition_cells <- partition_cells[[input$partitions]]

        cds_subset = cds$ptime[rownames(cds$ptime) %in% input$genePlotQuery1, colnames(cds$ptime) %in% partition_cells]

        if (any(grepl("integrated", colnames(colData(cds_subset))))){
          default_assay = "integrated"
        } else {
          default_assay = "RNA"
        }

        color_cells_by = paste0(default_assay, "_snn_res.", resolution())

        gene_ptime_plot <- monocle3::plot_genes_in_pseudotime(cds_subset,
                                 color_cells_by=color_cells_by,
                                 min_expr=0.5)

        print(gene_ptime_plot)

      })

      output$ptimeGenesDT <- renderDT({
        DT::datatable(cds_pr_test_res,
                      options = list(paging  = TRUE, pageLength = 15))
      })

      output$ptimeGenes <- renderUI({
        shinycssloaders::withSpinner(tagList(
          box(plotOutput(ns("ptimeGenesRedPlot")),
              width = 6),
          box(plotOutput(ns("ptimeGenesLinePlot")),
              width = 6),
          DTOutput(ns("ptimeGenesDT"))
                ))
      })

    })

}
whtns/seuratTools documentation built on March 25, 2020, 4:25 p.m.