##an example how to change the size of a button : , style = "height: 40px; width: 50%; font-size: 15px" 50% width means half the panel (column) setwd("~/switchdrive/Lab/Elizabeth/PrimeR/") # setwd("/home/elizabeth/Documents/R_Code/Shiny/PrimeR") source(paste0(getwd(),"/ShinyFunctions.R")) library(shiny, quietly=T) library(shinyFiles, quietly=T) library(shinythemes, quietly=T) library(shinyalert, quietly=T) library(shinyBS) library(shinyWidgets, quietly=T) library(shinybusy, quietly=T) library(plyr, quietly=T) library(dplyr, quietly=T) library(DT, quietly=T) library(png, quietly=T) library(Rsamtools, quietly=T) library(GenomicAlignments, quietly=T) # library(methylKit) library(rtracklayer, quietly=T) library(GenomicRanges, quietly=T) #library(HiCdatR, quietly=T) library(derfinder, quietly=T) library(stringr, quietly=T) library(RColorBrewer, quietly=T) library(colourpicker, quietly=T) # library(microseq, quietly=T) # Only needed for RNAseq tab library(Rsubread)##needed to get RNA seq counts library(edgeR)##RNA seq analysis library(limma) library(strawr)##needed for Hi-C library(shinyTree)##needed to create Hierarchy library(rrapply)##needed to create Hierarchy library(topGO)##needed for GO analysis library(biomaRt)##needed for GO analysis library(reshape2) library(shinybrowser)##allows to detect information about the browser (size, OS) and thus allows to adjust parameters such as the plotsize ui <- navbarPage(title = "PrimerR", theme = shinytheme("spacelab"), shinybrowser::detect(), header = tagList(add_busy_spinner(spin = "fading-circle", color = "#5A5A5A", margins = c(0, 10))), tabPanel("File Manipulation", navlistPanel( tabPanel("Load Files", shinyFilesButton(id = "fasta", label = "Load Fasta File", multiple = FALSE, title = "Browse"), shinyFilesButton(id = "gff", label = "Load GFF File", multiple = FALSE, title = "Browse"), shinyFilesButton(id = "desc", label = "Load Description File", multiple = FALSE, title = "Browse"), h4("Files in Use:"), checkboxInput(inputId = "useMod", label = "Use Modified Files", value = FALSE), h5("Fasta File:"), verbatimTextOutput(outputId = "fastaFile", placeholder = TRUE), h5("GFF File:"), verbatimTextOutput(outputId = "gffFile", placeholder = TRUE), h5("Description File:"), verbatimTextOutput(outputId = "descFile", placeholder = TRUE) ), tabPanel("Modify Fasta File", uiOutput("snames"), downloadButton(outputId = "fasMod", label = "Submit") ), tabPanel("Modify GFF File", # shinyFilesButton("gffpre", label = "Choose annotation file:", multiple = FALSE, title = "Browse"), splitLayout( wellPanel( h4("Rename Chromosomes:"), actionButton("selectAllname", "Select All"), bsButton("q11", label = "", icon = icon("question"), style = "info", size = "extra-small"), bsPopover(id = "q11", title = "Seqname Selection", content = "Seqnames must be selected (checked) to be included in the modified file.", placement = "right", trigger = "focus" ), actionButton("deselectAllname", "Deselect All"), uiOutput("anames") ), wellPanel( h4("Select features:"), actionButton("selectAllfeat", "Select All"), actionButton("deselectAllfeat", "Deselect All"), checkboxGroupInput("feature", "Select Features:") # Change this to group checkbox, can then be updated. ) ) , downloadButton(outputId = "gffMod", label = "Submit") ), tabPanel("Insert Sequence", textInput(inputId = "seqInsert", placeholder = "CGCGAATGCTAGCTTAC", label = p("Insertion Sequence:", tags$style(type = "text/css", "#q13 {vertical-align: middle;}"), bsButton("q13", label = "", icon = icon("question"), style = "info", size = "extra-small"))), bsPopover(id = "q13", title = "Insert Sequence", content = "Any invalid characters are converted to N. Valid characters include: A, C, G, T, M, R, W, S, Y, K, V, H, D, B, N.", placement = "right", trigger = "focus" ), shinyFilesButton("fileInsert", label = "Choose sequence file:", multiple = FALSE, title = "Browse"), textInput(inputId = "nameInsert", "insert name", placeholder = "Insert"), textInput(inputId = "chromInsert", "Chromosome", placeholder = "Chr1"), numericInput(inputId = "posInsert", label = p("Insertion Site:", tags$style(type = "text/css", "#q2 {vertical-align: middle;}"), bsButton("q2", label = "", icon = icon("question"), style = "info", size = "extra-small") ), value = 0.7e4, min = 1), bsPopover(id = "q2", title = "Insertion", content = "Inserted sequence wil begin at this base.", placement = "right", trigger = "focus" ), downloadButton(outputId = "insert", label = "Save Fasta"), downloadButton(outputId = "insertGFF", label = "Save GFF") ), tabPanel("Delete Sequence", textInput(inputId = "chromDelete", "Chromosome", placeholder = "Chr1"), numericInput(inputId = "startDelete", label = p("Deletion Start Position:", tags$style(type = "text/css", "#q3 {vertical-align: middle;}"), bsButton("q3", label = "", icon = icon("question"), style = "info", size = "extra-small") ), value = 0.7e3, min = 1), bsPopover(id = "q3", title = "Deletion", content = "Deletion includes both start and end base positions.", placement = "right", trigger = "focus" ), numericInput(inputId = "endDelete", label = "Deletion End Position:", value = 0.7e4, min = 1), downloadButton(outputId = "delete", label = "Save Fasta"), downloadButton(outputId = "deleteGFF", label = "Save GFF") ), tabPanel("Invert Sequence", textInput(inputId = "chromInvert", "Chromosome", placeholder = "Chr1"), numericInput(inputId = "startInvert", label = p("Inversion Start Position:", tags$style(type = "text/css", "#q4 {vertical-align: middle;}"), bsButton("q4", label = "", icon = icon("question"), style = "info", size = "extra-small") ), value = 0.7e3, min = 1), bsPopover(id = "q4", title = "Inversion", content = "Inversion includes both start and end base positions.", placement = "right", trigger = "focus" ), numericInput(inputId = "endInvert", label = "Inversion End Position:", value = 0.7e4, min = 1), downloadButton(outputId = "invert", label = "Save Fasta"), downloadButton(outputId = "invertGFF", label = "Save GFF") ), tabPanel("Mutate Single Base", textInput(inputId = "chromMutate", "Chromosome:", placeholder = "Chr1"), numericInput(inputId = "startMutate", label = p("Mutation Start Position:", tags$style(type = "text/css", "#q4 {vertical-align: middle;}"), bsButton("q5", label = "", icon = icon("question"), style = "info", size = "extra-small") ), value = 10, min = 1), bsPopover(id = "q5", title = "Mutation", content = "Mutation includes both start and end base positions. Ensure the mutated seqence contains the corect numver of bases.", placement = "right", trigger = "focus" ), numericInput(inputId = "endMutate", label = "Mutation End Position:", value = 12, min = 1), textInput(inputId = "baseMutate", label = p("Mutated Bases:", tags$style(type = "text/css", "#q4 {vertical-align: middle;}"), bsButton("q6", label = "", icon = icon("question"), style = "info", size = "extra-small") ), placeholder = "ACG"), bsPopover(id = "q6", title = "Mutated Bases", content = "Ensure the mutated seqence contains the corect number of bases to match the length specified above.", placement = "right", trigger = "focus" ), downloadButton(outputId = "mutate", label = "Submit") ), tabPanel("Transpose Sequence", h5("Sequence to Transpose:"), textInput(inputId = "chromTransp", "Chromosome:", placeholder = "Chr1"), numericInput(inputId = "startTransp", label = p("Start Position:", tags$style(type = "text/css", "#q4 {vertical-align: middle;}"), bsButton("q7", label = "", icon = icon("question"), style = "info", size = "extra-small") ), value = 0.7e3, min = 1), bsPopover(id = "q7", title = "Transposed Sequence", content = "Transposed sequence includes both start and end base positions.", placement = "right", trigger = "focus" ), numericInput(inputId = "endTransp", label = "End Position:", value = 0.7e4, min = 1), h5("Insertion Site:"), textInput(inputId = "chromTranspIns", "Chromosome:", placeholder = "Chr1"), numericInput(inputId = "posTranspIns", label = p("Insert Position:", tags$style(type = "text/css", "#q4 {vertical-align: middle;}"), bsButton("q8", label = "", icon = icon("question"), style = "info", size = "extra-small") ), value = 0.7e4, min = 1), bsPopover(id = "q8", title = "Insertion Site", content = "Transposed sequence begins at the base specified.", placement = "right", trigger = "focus" ), checkboxInput(inputId = "invertTransp", label = "Invert Sequence:", value = FALSE), downloadButton(outputId = "transp", label = "Save Fasta"), downloadButton(outputId = "transpGFF", label = "Save GFF") ), tabPanel("Reciprocally Translocate Sequence", h5("Sequence to Translocate:"), textInput(inputId = "chromTransA", "Chromosome:", placeholder = "Chr1"), numericInput(inputId = "startTransA", label = p("Start Position:", tags$style(type = "text/css", "#q4 {vertical-align: middle;}"), bsButton("q9", label = "", icon = icon("question"), style = "info", size = "extra-small") ), value = 0.7e3, min = 1), bsPopover(id = "q9", title = "Translocation", content = "Translocated sequence includes both start and end base positions.", placement = "right", trigger = "focus" ), numericInput(inputId = "endTransA", label = "End Position:", value = 0.7e4, min = 1), checkboxInput(inputId = "invertTransA", label = "Invert Sequence:", value = FALSE), h5("Insertion Site:"), textInput(inputId = "chromTransB", "Chromosome:", placeholder = "Chr1"), numericInput(inputId = "startTransB", label = p("Start Position:", tags$style(type = "text/css", "#q4 {vertical-align: middle;}"), bsButton("q10", label = "", icon = icon("question"), style = "info", size = "extra-small") ), value = 0.7e3, min = 1), bsPopover(id = "q10", title = "Translocation", content = "Translocated sequence includes both start and end base positions.", placement = "right", trigger = "focus" ), numericInput(inputId = "endTransB", label = "End Position:", value = 0.7e4, min = 1), checkboxInput(inputId = "invertTransB", label = "Invert Sequence:", value = FALSE), downloadButton(outputId = "trans", label = "Save Fasta"), downloadButton(outputId = "transGFF", label = "Save GFF") ), tabPanel("bam to bigwig", shinyFilesButton(id="bam_to_bw", label = "Choose .bam file:", multiple = FALSE, title = "Browse"), switchInput(inputId = "normBW", label = "normalize for total coverage", value = FALSE, width = "100%"), actionButton(inputId="bam2bwConv", label="Convert bam to bigwig") ) ), ), tabPanel("Genome Browser", sidebarLayout( sidebarPanel( # Navigation buttons fluidRow( column(1, actionButton("frameL", "", icon = icon("angles-left")), ), column(1, actionButton("minus", "", icon = icon("angle-left")), ), column(1, actionButton("plus", "", icon = icon("angle-right")), ), column(1, actionButton("frameR", "", icon = icon("angles-right")), ), column(3, actionButton(inputId = "update",label = "Refresh Plot") ) ), fluidRow( column(1, style = "margin-top: 25px;", actionButton("zi", "", icon = icon("magnifying-glass-plus")), ), column(2, style = "margin-top: 25px;", actionButton("zo", "", icon = icon("magnifying-glass-minus")), ), column(3, sliderInput(inputId = "zoomFac",label = "Zoom Factor", min = 1, max = 10, value = 2, step =1, width = "75px",ticks = FALSE) ), column(4, sliderInput(inputId = "gffHeight", label = "Plot Height", min=100, max = 500, step = 10, value = 240, ticks = FALSE, width = "75px") ) ), tabsetPanel(id = "settings", tabPanel("Navigation", br(), fluidRow( column(4, numericInput(inputId = "start", label = "From:", value = 0.7e4, min = 1, step = 500, width = "100%") ), column(4, numericInput(inputId = "end", label = "To:", value = 2e4, min = 1, step = 500) ), column(4, textInput(inputId = "chrom", label = "Chromosome:", value = "Chr1") ) ), fluidRow( column(12, actionButton("go", "Go to Region"), actionButton("remPos", "Save Location"), actionButton("pastPos", "Go to Saved Location") ) ), hr(style = "border-top: 1px solid #969696;"), fluidRow( column(12, textInput(inputId = "geneID", label = "Go to Gene:", value = NULL, placeholder = "AT1G09860"), actionButton("goButton", "Go to Gene") ) ), hr(style = "border-top: 1px solid #969696;"), fluidRow( column(12, textInput(inputId = "searchSeq", label = "Highlight Sequence:", value = NULL, placeholder = "ATGCCGTGGCTA"), actionButton("highlight", label = "Highlight"), bsButton("q12", label = "", icon = icon("question"), style = "info", size = "extra-small"), bsPopover(id = "q12", title = "Highlight Sequence", content = "Base sequence only appears at a view range smaller than 200 bases.", placement = "right", trigger = "focus" ) ) ), hr(style = "border-top: 1px solid #969696;"), fluidRow( column(12, downloadButton(outputId = "down", label = "Download the plot"), downloadButton(outputId = "fasDown", label = "Download sequence") ) ), ), tabPanel("Tracks", br(), actionButton("add", "Add Track", icon = icon("dna")), actionButton("remove", "Remove Selected Track", icon = icon("trash")), checkboxInput("global", "Global Ylim", value = FALSE), numericInput("g_ylim", "Globall Ylim Value", value = 10), tabsetPanel(id = "tabs") ), tabPanel("GFF Settings", br(), checkboxGroupInput(inputId="gff_features", label="Select Features:", choices = c(""), inline = TRUE) # dropdownButton(tags$style(".fa-cog {color:#ee2c2c}"),tags$h3("Feature Selection"),inputId = "mydropdown",label = "Feature Selection",icon = icon("cog"), width = "400px",status = "primary",circle = FALSE, # ) ), tabPanel("GFF Colours", br(), div(id ="colorPlace") ) ), ), # mainPanel( # plotOutput("annoContent", height = 240, width=900, hover = hoverOpts(id ="plot_hover"), brush = brushOpts(id = "anno_brush", resetOnNew = TRUE)), # div(id = "place2"), # htmlOutput("click_info") # ) mainPanel( uiOutput("anno"), div(id = "place2"), plotOutput("enhance"), htmlOutput("click_info") ) ) ), tabPanel("FISH", sidebarLayout( sidebarPanel( shinyDirButton(id = "work", label = "Choose Working directory", title = "Browse"), # shinyFilesButton(id = "fasta2", label = "FASTA File", multiple = FALSE, title = "Browse", width=200), tabsetPanel( id = "tabset", tabPanel("Probe Design" , textInput(inputId = "name", label = "Probe region label", value = "ROI_1"), textInput(inputId = "chromProbe", label = "Chromosome", value = "Chr1"), numericInput(inputId = "pos", label = "Centre position", 7071324), numericInput(inputId = "rad", label = "Search radius (bp)", 1e4), numericInput(inputId = "step", label = "Step size (bp)", 2e3) ), tabPanel("Primer3 Settings", numericInput(inputId = "min_prod", label = "Min. product size:", 1500), numericInput(inputId = "max_prod", label = "Max. product size:", 2000), numericInput(inputId = "min_GC", label = "Min. GC:", 20.0), numericInput(inputId = "max_GC", label = "Max. GC:", 80.0), numericInput(inputId = "min_Tm", label = "Min. Tm:", 57.0), numericInput(inputId = "max_Tm", label = "Max. Tm:", 63.0), selectInput(inputId = "settings", label = strong("Number of Additonal Settings:"),choices = c(0:5)), uiOutput("SetInput") ), tabPanel("Blast Settings", numericInput(inputId = "maxMM", label = "Max. Mismatches:", 5), numericInput(inputId = "maxMMend", label = "Max. Mismatches in 3' end:", 3), numericInput(inputId = "maxPDist", label = "Max. Primer Disatnce:", 1e4), numericInput(inputId = "maxAlign", label = "Max. Alignement Length:", 16), numericInput(inputId = "probeMM", label = "Probe Mismatches (?):", 2), numericInput(inputId = "probeAlign", label = "Probe Alignement:", 40), checkboxInput(inputId = "exHit", label = "Allow Exact Hits", value = TRUE), checkboxInput(inputId = "probeSpec", label = "Check Probe Specificity", value = FALSE) ), tabPanel("Virtual Gel", numericInput(inputId = "agar", label = "Agarose Percentage:", 1), numericInput(inputId = "volt", label = "Voltage:", 100), numericInput(inputId = "time", label = "Time:", 90), ) ), actionButton(inputId = "submit", label = "Submit") ), mainPanel( plotOutput("gel", height = 360, width = 600), tableOutput("primer") ) ) ), tabPanel("Chromatin State", sidebarLayout( sidebarPanel( # h1("Chromatin State Analysis"), selectInput(inputId = "data", label = "Data Set Selection", choices = c("Sequira 2014", "PCSD"), width = "40%"), tabsetPanel( tabPanel("Single ROI", verticalLayout( selectInput(inputId = "chromS", label = "Chromosome", choices = c("chr1", "chr2", "chr3", "chr4", "chr5"), width = "40%"), textInput(inputId = "chromGene", label = "Gene ID:", value = NULL, placeholder = "AT1G09860"), numericInput(inputId = "startS", label = "From", value = 7068824, min = 0), numericInput(inputId = "endS", label = "To", value = 7073824, min =0), actionButton(inputId = "go1", label = "Generate graph"), actionButton(inputId = "chromGeneGo", label = "Plot for Gene") ), h4("Find Similar Region:"), textInput(inputId = "range", label = "Search Range", value = 5000000), textInput(inputId = "buff", label = "Buffer Zone", value = 400000), textInput(inputId = "size", label = "Search Size", value = 5000), textInput(inputId = "ln", label = "Leniency Factor", value = 0.25), textInput(inputId = "state", label = "Number of Matching States", value = 2), textInput(inputId = "lim", label = "State Proportion Limit", value = 10), actionButton(inputId = "go4", label = "Find Candidates") ), tabPanel("Group State Average", shinyFilesButton(id = "file", label = "Upload File", multiple = FALSE, title = "Browse"), actionButton(inputId = "go2", label = "Generate graphs"), downloadButton(outputId = 'down2', label = "Download Graph") ), tabPanel("Compare Group Averages", shinyFilesButton(id = "file1", label = "Upload File", multiple = FALSE, title = "Browse"), shinyFilesButton(id = "file2", label = "Upload File", multiple = FALSE, title = "Browse"), actionButton(inputId = "go3", label = "Generate graphs") ), ), ), mainPanel( plotOutput(outputId = "relative"), DTOutput(outputId = "table"), plotOutput(outputId = "candrel"), DTOutput(outputId = "candidate"), textOutput(outputId = "alert"), plotOutput(outputId = "relative2") ) ) ), tabPanel(title = "RNASeq", sidebarLayout( sidebarPanel( tabsetPanel( tabPanel("Hierarchy", h5("Establish GFF Hierarchy:"),###HOLDRIO shinyFilesButton(id = "hierachLoad", label = "Load GFF Hierachy", multiple = FALSE, title = "Browse", icon = icon("folder-open"), style = "width:40%"), actionButton(inputId = "hierach", label = "Create GFF Hierachy", icon=icon("wand-magic-sparkles"), style = "width:40%"), bsButton("q1", label = "", icon = icon("question"), style = "info", size = "extra-small"), bsPopover(id = "q1", title = "GFF Hierachy", content = "Creates a GFF file with additional columns showing parent child relationships between features.", placement = "right", trigger = "focus" ), ######BUGGING COMMENT: Does this actually work???? downloadButton(outputId = "hierachSave", label = "Save GFF Hierachy", style = "width:40%") ), tabPanel("counts", shinyFilesButton(id = "RNAFiles", label = "Load BAM", multiple = TRUE, title = "Browse", icon = icon("folder-open"), style = "width:40%"),##select bam files for making count tables prettySwitch(inputId = "useHierach", label = "Use Hierachy", value = FALSE, fill = TRUE, status = "primary"), uiOutput("RNAfeatures"), actionButton(inputId = "selectionCheck", label="verify selected features", style = "width:40%"), dropdownButton(tags$h3("count parameters"),inputId = "mydropdown",label = "count parameters",icon = icon("cog"),status = "primary",circle = FALSE, #tags$style(".fa-cog {color:#ee2c2c}"), selectInput(inputId="RNA_strandSpecific", "strand", choices = c("unstranded" = 0,"stranded" = 1, "reversely stranded" = 2), selected = 0), prettySwitch(inputId = "RNA_largestOverlap",label = "largestOverlap",fill = TRUE, status = "primary", value = FALSE), prettySwitch(inputId = "RNA_countMultiMappingReads",label = "countMultiMappingReads",fill = TRUE, status = "primary", value = FALSE), prettySwitch(inputId = "RNA_fraction",label = "fraction",fill = TRUE, status = "primary", value = FALSE), prettySwitch(inputId = "RNA_splitOnly",label = "splitOnly",fill = TRUE, status = "primary", value = FALSE), prettySwitch(inputId = "RNA_primaryOnly",label = "primaryOnly",fill = TRUE, status = "primary", value = FALSE), prettySwitch(inputId = "RNA_ignoreDup",label = "ignoreDup",fill = TRUE, status = "primary", value = FALSE), prettySwitch(inputId = "RNA_isPairedEnd",label = "isPairedEnd",fill = TRUE, status = "primary", value = FALSE), prettySwitch(inputId = "RNA_requireBothEndsMapped",label = "requireBothEndsMapped",fill = TRUE, status = "primary", value = FALSE), prettySwitch(inputId = "RNA_countChimericFragments",label = "countChimericFragments",fill = TRUE, status = "primary", value = FALSE), textInput(inputId="RNA_minOverlap", label = "minOverlap", value = 1), textInput(inputId="RNA_minMQS", label = "minMQS", value = 0), textInput(inputId="RNA_minFragLength", label = "minFragLength", value = 50), textInput(inputId="RNA_maxFragLength", label = "maxFragLength", value = 600), textInput(inputId="RNA_nthreads", label = "nthreads", value = 1) ), actionButton(inputId = "count", label = "Run Count Analysis", icon = icon("wand-magic-sparkles"),style = "color: #ee2c2c; width: 40%"),## create count tables downloadButton(outputId = "countDown", label = "Save Count Data", style = "width:40%"), shinyFilesButton(id = "countLoad", label = "Load Count Data", multiple = FALSE, title = "Browse", icon = icon("folder-open"), style = "width:40%"), ##load previously made count tables ), tabPanel("DE analysis", fluidRow(##to drop down menues to select controls and samples column(6, tags$head(tags$style(type="text/css", '.ovfl .shiny-bound-input{overflow-x: scroll;}')), ###here we intorduce the slider on the x, in case the text is too long in a drop down very useful dropdownButton(tags$style(".fa-cog {color:#ee2c2c; width:40%}"),inputId = "mydropdown",label = "choose controls",icon = icon("vial"),status = "primary",circle = FALSE, width = "100%", tags$div(class="ovfl",checkboxGroupInput(inputId="RNAConFiles",label="choose controls",choices = c(""),inline = TRUE, selected = c(""))) ) ), column(6, dropdownButton(tags$style(".fa-cog {color:#ee2c2c; width:40%}"),inputId = "mydropdown",label = "choose samples",icon = icon("vial"),status = "primary",circle = FALSE, width = "100%", tags$div(class="ovfl",checkboxGroupInput(inputId="RNASampFiles",label="choose samples",choices = c(""),inline = TRUE, selected = c(""))) ) ), numericInput(inputId = "RNAminCount", label = "Mimumum Count:", value = 10, min = 0, width = "40%"), numericInput(inputId = "RNAminCountTotal", label = "Minimum Total Count:", value = 15, min = 0, width = "40%"), actionButton(inputId = "RNAgo", label ="Run DE analysis", icon=icon("wand-magic-sparkles"), style = "color: #ee2c2c;width:40%"), downloadButton(outputId = "DEDown", label = "Save DE analysis to file", style = "width:40%") ) ), tabPanel("plots", actionButton(inputId = "moveToHit", label = "Display in Browser", style = "width:40%"), actionButton(inputId = "additionalGeneInfo", label = "gene information", style = "width:40%"), h5("Plot Settings:"), numericInput(inputId = "RNApThresh", label = "p-value Threshold:", value = 0.01, min = 0, width = "40%"), numericInput(inputId = "RNAFC", label = "Fold Change:", value = 2, min = 0, width = "40%") ), tabPanel("GO", h5("GO Analysis"), selectInput(inputId = "GOgroup", "Select GO mart", choices = c("none","plants", "ensembl","fungi", "protists","metazoa"), width = "40%"), selectInput(inputId = "GOspecies", "Select Species", choices = c(""), width = "40%"), actionButton(inputId = "goGO", label = "Run GO analysis",icon=icon("wand-magic-sparkles"), style = "color: #ee2c2c;width:40%"), downloadButton(outputId = "GODown", label = "Save GO to file", style = "width:40%"), selectInput(inputId = "GOcat", label = "Select GO category", choices = c("Biological Process"="BP","Molecular Function"="MF","Cellular Component"="CC"), width = "40%", selected = "BP"), selectInput(inputId = "GOterm", label = "Highlight GO term", choices = c(""), width = "40%"), ) ) ), mainPanel( fluidRow( column(width = 6, plotOutput("volcano1", height = 300,brush = brushOpts(id = "volcano_brush",resetOnNew = TRUE)) ), column(width = 6, plotOutput("volcano2", height = 300, click = "volcano_click") ) ), ###making the valcono plot brushable # plotOutput(outputId = "RNAplot",dblclick = "volcano_dblclick",brush = brushOpts(id = "volcano_brush",resetOnNew = TRUE)), # plotOutput("RNAplot", click = "volcano_click", dblclick = "volcano_dblclick",brush = brushOpts(id = "volcano_brush",resetOnNew = TRUE)),##for clicking on a dot and gettting the gene name... DTOutput(outputId = "RNAtable"), plotOutput(outputId = "GOplot", height = 300, click = "GO_click"), DTOutput(outputId = "GOtable") ) ) ), tabPanel("Help", h5("Welcome to PrimeR! For guides, reccomendations and tips for using the app look below."), tabsetPanel( tabPanel("File Manipulaiton"), tabPanel("Genome Browser"), tabPanel("FISH"), tabPanel("Chromatin State") ) ) ) addColorUI <- function(id, col = col){ ns <- NS(id) #flowLayout( div( id = id, #colourInput(inputId = id, label = id, value = "red", showColour = "background", closeOnClick = FALSE), colourpicker::colourInput(inputId = ns("col"), label = id, value = col, closeOnClick = FALSE)#, #uiOutput(ns("colorPlace")) ) #) } addColorServer <- function(id, session){ moduleServer( id, function(input, output, session){ observe({ session$userData$GFF_cols[[id]][["col"]] <- paste(input$col) }) } ) } # UI for plot output of added track plotUI <- function(id, numTracks){ ns <- NS(id) flowLayout( div( id = id, plotOutput(ns("plot"), dblclick = dblclickOpts(id = ns("plot_click_track"), clip = TRUE), height = 180, width=get_width()*2/3) #changed width form 1160... # plotOutput(ns("plot"), brush = "plot_brush", height = 180/numTracks, width = 1160) # this works but doesn't make sense now as it only applies to current track but not to the previous ones.... ) ) } # Server for drop down choice/add track addServer <- function(id, NumTracks){ moduleServer( id, function(input, output, session){ # # Remove track action: works but empty space built up over multiple deletions # observeEvent(input$remove, { # session$userData$tracks <- session$userData$tracks[names(session$userData$tracks) != id] # removeUI( # selector = paste0("#", id) # ) # }) ns <- NS(id) colVec <- f.create.col.list(n = length(c(19:30)), transparancy = 0.5, style = "RdYlBu") # colVec <- sample(colVec) # UI for file input and y axis length slider: can be edited to show different UI based on drop down choice. output$place3 <- renderUI({ if(input$choice == "sRNA") { tagList( shinyFilesButton(ns("file"), "Select File", "Choose File", multiple = TRUE, icon=icon("folder-open"), width = "400px"), tabsetPanel(id = "sRNAtab", tabPanel("Settings", switchInput(ns("rpm"), label = "RPM", value = FALSE, width = "100%"), textInput(ns("yLim"), label = "max ylim", value = 100), checkboxInput(ns("setYlim"), label = "set ylim", value = FALSE, width = "100%"), checkboxGroupInput(inputId=ns("siRNA_size"),label="Choose sRNA size to display:",choices = c(19:30),inline = TRUE, selected = c(21,22,23,24)) ), tabPanel("Asthetics", colourInput(inputId = ns("col19"), label = "19", value = colVec[1], closeOnClick = FALSE), colourInput(inputId = ns("col20"), label = "20", value = colVec[2], closeOnClick = FALSE), colourInput(inputId = ns("col21"), label = "21", value = colVec[3], closeOnClick = FALSE), colourInput(inputId = ns("col22"), label = "22", value = colVec[4], closeOnClick = FALSE), colourInput(inputId = ns("col23"), label = "23", value = colVec[5], closeOnClick = FALSE), colourInput(inputId = ns("col24"), label = "24", value = colVec[6], closeOnClick = FALSE), colourInput(inputId = ns("col25"), label = "25", value = colVec[7], closeOnClick = FALSE), colourInput(inputId = ns("col26"), label = "26", value = colVec[8], closeOnClick = FALSE), colourInput(inputId = ns("col27"), label = "27", value = colVec[9], closeOnClick = FALSE), colourInput(inputId = ns("col28"), label = "28", value = colVec[10], closeOnClick = FALSE), colourInput(inputId = ns("col29"), label = "29", value = colVec[11], closeOnClick = FALSE), colourInput(inputId = ns("col30"), label = "30", value = colVec[12], closeOnClick = FALSE) )) # dropdownButton(tags$style(".fa-cog {color:#ee2c2c}"),tags$h3("track settings"),inputId = "mydropdown",label = "Controls",icon = icon("cog"), width = "400px",status = "primary",circle = FALSE, # # ) ) } else if(input$choice == "mRNA") { # if (is.null(ylim_ls[[id]])){ymax <- 20} else {ymax <- ylim_ls[[id]]} ###doesn't work as this is not reloaded every time we change the plot..... tagList( shinyFilesButton(ns("file"), "Select File", "Choose File", multiple = TRUE, icon=icon("folder-open"), width = "400px"), # switchInput(ns("rpm"), label = "RPM", value = FALSE, width = "100%") # dropdownButton(tags$style(".fa-dial {color:#ee2c2c}"),inputId = "mydropdown",label = "Controls",icon = icon("sliders"),status = "primary",circle = FALSE, dropdownButton(tags$style(".fa-cog {color:#ee2c2c}"),tags$h3("track settings"),inputId = "mydropdown",label = "Controls",icon = icon("cog"), width = "400px",status = "primary",circle = FALSE, switchInput(ns("rpm"), label = "RPM", value = FALSE, width = "100%"), textInput(ns("yLim"), label = "max ylim", value = 100), checkboxInput(ns("setYlim"), label = "set ylim", value = FALSE, width = "100%"), # checkboxInput(ns("setRef"), label = "set as reference", value = session$userData$tracks[[id]][["reference"]] , width = "100%") ## this trick doesn't work.. sniff... checkboxInput(ns("setRef"), label = "set as reference", value = FALSE , width = "100%") ) ) } else if(input$choice == "mC") { # if (is.null(ylim_ls[[id]])){ymax <- 20} else {ymax <- ylim_ls[[id]]} ###doesn't work as this is not reloaded every time we change the plot..... tagList( shinyFilesButton(ns("file"), "Select File", "Choose File", multiple = TRUE, icon("folder-open")), dropdownButton(tags$style(".fa-cog {color:#ee2c2c}"),tags$h3("track settings"),inputId = "mydropdown",label = "Controls",icon = icon("cog"), width = "400px",status = "primary",circle = FALSE, checkboxGroupInput(inputId=ns("mC_context"),label="choose mC contexts",choices = c("CpG" ="CpG","CHH"="CHH","CHG"="CHG"),inline = TRUE, selected = c("CpG", "CHH", "CHG"))#, # checkboxInput(ns("mC_availability"), label = "select all available mC contexts", value = FALSE, width = "100%") ) ) } else if(input$choice == "HiC") { tagList( shinyFilesButton(ns("file"), "Select File", "Choose File", multiple = TRUE, icon("folder-open")), actionButton(ns("hicgo"), "Generate Plot"), dropdownButton(tags$style(".fa-cog {color:#ee2c2c}"),tags$h3("track settings"),inputId = "mydropdown",label = "Controls",icon = icon("cog"), width = "400px",status = "primary",circle = FALSE, selectInput(inputId=ns("HiCtype"), "choose HiC type", choices = c("Hi-C" = "Hi-C","2D Hi-C" = "HIC2D", "virt4C" = "virt4C"), selected = c("Hi-C"),width = "40%"), selectInput(inputId=ns("HiCnorm"), label="choose nomalization", choices = c("NONE" = "NONE","VANILLA" = "VC", "SQRT_VANILLA" = "VC_SQRT", "BALANCED" = "KR"), selected = c("NONE"),width = "40%"), selectInput(inputId=ns("HiCmatrixType"), label="choose matrix type", choices = c("OBSERVED" = "observed","EXPECTED" = "expected", "OBSERVED/EXPECTED" = "oe"), selected = c("oe"),width = "40%"), textInput(inputId=ns("VP"), label = "set 4C viewpoint", value = 1950000), textInput(inputId=ns("VPchrom"), label = "set viewpoint chrom", value = "Chr1"), textInput(inputId=ns("chrom2"), label = "set second chrom", value = "Chr3"), textInput(inputId=ns("start2"), label = "set second start", value = 20000000), textInput(inputId=ns("end2"), label = "set second end", value = 23000000), textInput(inputId=ns("binSize"), label = "bin size", value = 1e4) ) ) } else if(input$choice == "Chromatin State") { selectInput(inputId = ns("data"), label = "Data Set Selection", choices = c("Sequira 2014", "PCSD")) } }) } ) } # If you need values from outside of the namespace given (i.e. id) need to include it in the parameters of the function (see plotServer) # More specifically: if you need reactive values that are global (e.g. in this case start/end co-ordinates etc.) must assign them as reactive in the main server # then write them as reactive within the module too (e.g. start()) # Server for plotting added track plotServer <- function(id, start, end, chrom, global, g_ylim, ls, fas, chromList, PCSDdata, SMdata){ moduleServer( id, function(input, output, session){ # # Remove track action: removes plot # observeEvent(input$remove, { # removeUI( # selector = paste0("#", id) # ) # system(paste0("rm ",getwd(),"/primeR_dat/tmp/",id,".primeRstore")) # }) # # Plot chromatin state track output$plot <- renderPlot({ if(input$choice == "Chromatin State"){ if (input$data == "PCSD"){ stateDF <- PCSDdata } else if (input$data == "Sequira 2014"){ stateDF <- SMdata } f.plot.chromatin.state(x = c(as.character(chrom()), as.numeric(start()), as.numeric(end())), stateDF = stateDF) } }) # For some reason doesn't like having if statement first e.g. if(input$choice == "sRNA"): due to above. Works within a render function, though v <- reactiveValues(data = 500) # volumes <- c(Home = fs::path_home(), "R Installation" = R.home(), getVolumes()()) # Replaced volumes with c(wd = ".") below. Just set wd to desired file. session$userData$tracks[[id]][["clickCount"]] <- 1 observeEvent(input$plot_click_track, {##has to be at the beginning otherwise it starts to run several times v$plotx <- round(as.numeric(input$plot_click_track$x)) v$ploty <- round(as.numeric(input$plot_click_track$y)) session$userData$tracks[[id]][["clickCount"]] <- session$userData$tracks[[id]][["clickCount"]]+1 print(paste0("before:",session$userData$tracks[[id]][["clickCount"]])) session$userData$tracks[[id]][["clickCount"]] <- floor(session$userData$tracks[[id]][["clickCount"]]) print(session$userData$tracks[[id]][["clickCount"]]) }) observeEvent(input$file, { volumes <- c(Home = fs::path_home(), "R Installation" = R.home(), getVolumes()()) shinyFileChoose(input, "file", roots = volumes, filetypes = c('bed', 'bam', 'bigWig','bw','bigwig','hic'), defaultPath = '~/primeR_dat/', restrictions = c("/bin", "/boot", "/dev", "/etc", "/lib", "/lib32", "/lib64", "/opt", "/proc", "/run", "/sbin", "/snap", "/sys", "/usr", "/var", "/root", "/srv", "/tmp", "/mnt", "/lost+found", "/cdrom")) v$track <- parseFilePaths(volumes, input$file)$datapath session$userData$tracks[[id]][["fileNames"]] <- v$track ##just add soem info to our list for plotting later session$userData$tracks[[id]][["type"]] <- input$choice ##just add soem info to our list for plotting later ##create general data for data files, this is done only when file is loaded the first time and not repeated each time we move around... speeds up the process! if (input$choice %in% c("sRNA", "mRNA")){ format_ls <- list(bam = c("bam"), bw = c("bw", "bigwig", "bigWig")) files_ls <- list() for (format in names(format_ls)){ files_ls[[format]] <- v$track[grep(pattern = format, x = v$track)] } track_info_ls <- list() files_ls <- files_ls[lapply(files_ls,length)>0] for(format in names(files_ls)){print(format) ; track_info_ls[["libsize"]][[format]] <- f.library.size(files_ls[[format]], format)} session$userData$tracks[[id]][["fileNames"]] <- files_ls } ls <- list(type = input$choice, data = v$track) saveRDS(ls, file= paste0(getwd(),"/primeR_dat/tmp/",id,".primeRstore")) # Action button to plot HiC graph ('saves' inputs.) if(input$choice == "HiC"){ observeEvent(input$hicgo, { v$HiCnorm <- input$HiCnorm v$HiCmatrixType <- input$HiCmatrixType v$VP <- input$VP v$VPchrom <- input$VPchrom v$chrom2 <- input$chrom2 v$start2 <- input$start2 v$end2 <- input$end2 v$binSize <- as.numeric(input$binSize) }) } output$plot <- renderPlot({ print(paste0("inside1:",session$userData$tracks[[id]][["clickCount"]])) start <- floor(start()) #### HERE IS PROBABLY NEEDED TO NOT HAVE COMMAS, WHICH MESS UP PLOTTING!!!!!!!!!!!! NOT ADAPTED EVERYWHERE YET!!! ALSO SHOULD BE DONE ON A HIGHER LEVEL!!!!!! end <- floor(end()) #### HERE IS PROBABLY NEEDED TO NOT HAVE COMMAS, WHICH MESS UP PLOTTING!!!!!!!!!!!!NOT ADAPTED EVERYWHERE YET!!! ALSO SHOULD BE DONE ON A HIGHER LEVEL!!!!!! par(mar = c(0.5,4,0,2)) if(input$choice == "sRNA"){### sRNA plotting ##later add again something like this: & nchar(v$track)>1 maybe in a seperate if() if (nchar(v$track)>1){ sRNAdat <- f.reads.extract.minimal(chrom = chrom(), start = start(), end = end(), bamPATHin = v$track, threads = 4) if(length(intersect(as.numeric(input$siRNA_size),as.numeric(sRNAdat$length)))==0){ plot(1,1,xlim=c(start(), end()),ylim = c(-1,1), type = "n", bty = "n", xaxt = "n", ylab="coverage",xlab="") abline(h=0) abline(h=c(1,-1), lty = "dashed") } else { count <- 0 colList <- list() for(name in input$siRNA_size){ count <- count+1 colList[[count]] <- input[[paste0("col",name)]] } if ((as.numeric(end()) - as.numeric(start())) > 5e4){ # When get onto ylim issue: NULL = ylim just determined by data, can set it to reactive based on input later. print(paste0("print the glocabl", global())) if(global() == TRUE){ ylim <- as.numeric(g_ylim()) } else if(input$setYlim == TRUE){ ylim <- as.numeric(input$yLim) } else {ylim <- NULL} session$userData$tracks[[id]][["ylim"]] <- ylim session$userData$tracks[[id]][["rpm"]] <- input$rpm session$userData$tracks[[id]][["sizes"]] <- input$siRNA_size session$userData$tracks[[id]][["col"]] <- v$colList session$userData$tracks[[id]][["lib_size"]] <- track_info_ls[["libsize"]][["bam"]] f.binned.plotter.sRNA(inTAB = sRNAdat, binsize = NULL, start = start(), end = end(), sizes = input$siRNA_size, col = colList, xlim = c(start(), end()), ylimit = ylim, main = NULL, rpm = input$rpm, TotLibReads = track_info_ls[["libsize"]][["bam"]]) } else { if(global() == TRUE){ ylim <- as.numeric(g_ylim()) } else if(input$setYlim == TRUE){ ylim <- as.numeric(input$yLim) } else {ylim <- NULL} session$userData$tracks[[id]][["ylim"]] <- ylim session$userData$tracks[[id]][["rpm"]] <- input$rpm session$userData$tracks[[id]][["sizes"]] <- input$siRNA_size session$userData$tracks[[id]][["lib_size"]] <- track_info_ls[["libsize"]][["bam"]] tmp <- f.coverage.plotter.sRNA(inDAT = sRNAdat, stranded = TRUE, sizes = input$siRNA_size, col = colList, rpm = input$rpm, TotLibReads = track_info_ls[["libsize"]][["bam"]], start = start, end = end, ylim = ylim, title = paste(id, ":", input$choice, sep = " "), normFac = NULL) if (input$setYlim == FALSE) {updateTextInput(inputId = "yLim", value = tmp)} } } } } else if(input$choice == "mRNA"){### mRNA plotting print("mRNA we chose") others_same_type <- names(session$userData$tracks[str_detect(session$userData$tracks, input$choice)]) ## this are the ids of the tracks of the same data type.... if (input$setRef == TRUE){ session$userData$tracks[[id]][["reference"]] <- "isRef" for (others in others_same_type[others_same_type != id]){ ## only one can be the reference session$userData$tracks[[others]][["reference"]] <- "isNotRef" ##thats fine # updateCheckboxInput(session = session,inputId = paste0(others,"-setRef"),value = FALSE) ## seems not to work.... } } print(paste0("these are the others:",others_same_type)) refSets <- names(session$userData$tracks[str_detect(session$userData$tracks, "isRef")])##this works fine, so we can change the list of other namespaces.... if ((as.numeric(end()) - as.numeric(start())) <= 5e4){ if (input$setYlim == TRUE){ ylim <- as.numeric(input$yLim) } else if (length(refSets)>0){ ylim <- session$userData$tracks[[refSets]][["ylim"]] } else {ylim <- NULL} session$userData$tracks[[id]][["ylim"]] <- ylim session$userData$tracks[[id]][["rpm"]] <- input$rpm session$userData$tracks[[id]][["lib_size"]] <- track_info_ls[["libsize"]][["bam"]] tmp <- f.coverage.plotter.mRNA_RsamTools(bamfile = files_ls[["bam"]], chrom = chrom(), start = start(), end = end(), ylim=ylim, rpm = input$rpm, TotLibReads = track_info_ls[["libsize"]][["bam"]], stranded = TRUE) if (input$setYlim == FALSE) {updateTextInput(inputId = "yLim", value = tmp)} # updateSliderInput(inputId = "yLim", max = tmp) ### so easy so far... not sure what happens when there is several tracks...... } else if ((as.numeric(end()) - as.numeric(start())) > 5e4){ if("bw" %in% names(files_ls)){ if (input$setYlim == TRUE){ylim <- as.numeric(input$yLim)} else {ylim <- NULL} session$userData$tracks[[id]][["ylim"]] <- ylim session$userData$tracks[[id]][["rpm"]] <- input$rpm session$userData$tracks[[id]][["lib_size"]] <- track_info_ls[["libsize"]][["bw"]] tmp <- f.binned.plotter.minimal_2(inBigWig=files_ls[["bw"]], binsize = NULL, chr = as.character(chrom()), start = as.numeric(start()), end = as.numeric(end()), xlim = c(as.numeric(start()), as.numeric(end())), ylimit = ylim, main = NULL, rpm = input$rpm, libsize = track_info_ls[["libsize"]][["bw"]]) if (input$setYlim == FALSE) {updateTextInput(inputId = "yLim", value = tmp)} } else { plot(1,1, type ="n", xlim =c(start(), end()), ylim =c(0,5), xaxt = "n", xlab= "", yaxt = "n", ylab ="", bty = "n") text(x=mean(c(start(), end())),y=2, label = "no bw file available - data not shown at > 200kb") } } } else if(input$choice == "mC"){### mC plotting context_ls <- list(CpG = "CpG|CG", CHH = "CHH", CHG = "CHG", DAM = "DAM") files_ls <- list() for (context in names(context_ls)){ files_ls[[context]] <- v$track[grep(pattern = context_ls[[context]], x = v$track)] } files_ls <- files_ls[lapply(files_ls,length)>0] # if (input$mC_availability == TRUE){updateCheckboxGroupInput(inputId="mC_context",choices = names(files_ls), selected = NULL)} ### this one doesn't work as it constantly overrides the choices... # updateCheckboxGroupInput(inputId="mC_context",choices = names(files_ls), selected = NULL) ## also doesn't work as wished, they always interfere with the selection... they automatically unselect.. its probably normal... valid_contexts <- input$mC_context[input$mC_context %in% names(files_ls)] ### this simply prevents from potential bugs..... meth_ls <- list() session$userData$tracks[[id]][["contexts"]] <- valid_contexts session$userData$tracks[[id]][["meth_files"]] <- files_ls for (context in valid_contexts){meth_ls[[context]] <- f.import.bigWigSelection(infile = files_ls[[context]],chr=chrom(),start=start(), end=end())} session$userData$tracks[[id]][["meth_data"]] <- meth_ls if ((as.numeric(end()) - as.numeric(start())) <= 5e4){ f.methylation.plotter.detail(inDat = meth_ls, chrom(), start(), end()) } else if ((as.numeric(end()) - as.numeric(start())) > 5e4){ f.methylation.plotter.binned(inDat = meth_ls, chrom = chrom(), start = start(), end = end(), binSize = NULL, thresh_ls = list(CpG = 20, CHH = 5, CHG = 5)) } #else { # plot(1,1, type ="n", xlim =c(start(), end()), ylim =c(0,5), xaxt = "n", xlab= "", yaxt = "n", ylab ="", bty = "n") #text(x=mean(c(start(), end())),y=2, label = "data not shown at > 200kb") #} } # Have tried to hook an action button up here, but can't get it to work... else if(input$choice == "HiC"){### mC plotting # Returns the co-ord for the plot click only on Hi-C plots, not from other tracks. (though 'plot_click' exists for every track, so could use click in any of them) # Can then save the x/y as global values (session$userData) as below, for later use. If not needed in pdf plot, can probably leave as local values. print(paste0("inside2:",session$userData$tracks[[id]][["clickCount"]])) if(is.null(v$VP)){return()} else { if (length(v$track)>0){ session$userData$tracks[[id]][["binSize"]] <- v$binSize session$userData$tracks[[id]][["HiCnorm"]] <- v$HiCnorm session$userData$tracks[[id]][["HiCtype"]] <- input$HiCtype session$userData$tracks[[id]][["HiCmatrixType"]] <- v$HiCmatrixType session$userData$tracks[[id]][["chrom2"]] <- v$chrom ##is this still working when there is more than 1 Hi-C track???? session$userData$tracks[[id]][["start2"]] <- v$start2 session$userData$tracks[[id]][["end2"]] <- v$end2 if (input$HiCtype == "virt4C"){ session$userData$tracks[[id]][["VP"]] <- input$VP f.plot.dot.hic.virtual4C(norm=v$HiCnorm, fname = v$track, VPchrom = v$VPchrom, VPpos = as.numeric(v$VP),chrom = as.character(chrom()), start = as.numeric(start()), end = as.numeric(end()), binSize=v$binSize, matrix = "oe", log = FALSE) } else if (input$HiCtype == "Hi-C"){ out <- f.plot.dot.hic.data(norm=v$HiCnorm, fname = v$track, chrom = chrom(), start = start(), end = end(), binSize=1e4, matrix = v$HiCmatrixType, log = TRUE, devSize = dev.size("in")[2]) if (is.numeric(v$plotx) & is.wholenumber(session$userData$tracks[[id]][["clickCount"]]/2)){ backTrafo <- f.retransform(x = v$plotx,y = v$ploty,xlim = c(start(),end()), maxx1 = out[["x1max"]], maxy1 = out[["y1max"]]) if (backTrafo[["x"]] > start() & backTrafo[["x"]] < end() & backTrafo[["y"]] > start() & backTrafo[["y"]] < end()){##this allows to "unckick" when we click outside the triangle height <- strheight(round(backTrafo[["x"]]))*1.5 xwidth <- strwidth(round(backTrafo[["x"]]))*1.5 ywidth <- strwidth(round(backTrafo[["y"]]))*1.5 if (round(backTrafo[["x"]])+xwidth/2 < round(backTrafo[["y"]])-ywidth/2){ rect(xleft = backTrafo[["x"]]-xwidth/2, xright=backTrafo[["x"]]+xwidth/2, ybottom = 0-height/2, ytop = height*1.75, col = rgb(255,255,255,200, max = 255), border = NA) rect(xleft = backTrafo[["y"]]-ywidth/2, xright=backTrafo[["y"]]+ywidth/2, ybottom = 0-height/2, ytop = height*1.75, col = rgb(255,255,255,200, max = 255), border = NA) text(backTrafo[["x"]], 0, label = round(backTrafo[["x"]]), pos = 3, font = 2,cex=1.5) text(backTrafo[["y"]], 0, label = round(backTrafo[["y"]]), pos = 3, font = 2, cex=1.5) } else { rect(xleft = backTrafo[["x"]]-xwidth/2, xright=backTrafo[["x"]]+xwidth/2, ybottom = 0-height/2, ytop = height*1.75, col = rgb(255,255,255,200, max = 255), border = NA) rect(xleft = backTrafo[["y"]]-ywidth/2, xright=backTrafo[["y"]]+ywidth/2, ybottom = height*1.75, ytop = height*1.75+height*1.75, col = rgb(255,255,255,200, max = 255), border = NA) text(backTrafo[["x"]], 0, label = round(backTrafo[["x"]]), pos = 3, font = 2,cex=1.5) text(backTrafo[["y"]], height*1.5, label = round(backTrafo[["y"]]), pos = 3, font = 2, cex=1.5) } shinyalert(title = "Approximate Position", type = "info", text = paste0("contact between ",round(backTrafo[["x"]]), " and ",round(backTrafo[["y"]]))) points(c(backTrafo[["x"]],backTrafo[["y"]]),c(0,0), pch = 17, cex=1.5) lines(c(backTrafo[["x"]], v$plotx), c(0, v$ploty), lty = "dashed", lwd = 2) lines(c(backTrafo[["y"]], v$plotx), c(0, v$ploty), lty = "dashed", lwd = 2) } } } else if (input$HiCtype == "HIC2D"){ observeEvent(input$plot_click, { ###why is it printed so many times????? v$plotx <- round(as.numeric(input$plot_click$x)) v$ploty <- round(as.numeric(input$plot_click$y)) }) f.plot.dot.hic.data.2D(norm=v$HiCnorm, fname = v$track, chromA = chrom(), startA = as.numeric(start()), endA = as.numeric(end()), chromB = v$chrom2, startB = as.numeric(v$start2), endB = as.numeric(v$end2), binSize=v$binSize, matrix = v$HiCmatrixType, log = FALSE) if (is.numeric(v$plotx) & v$plotx < end()-(end()-start())*0.1){ ###this only works if anything has been clicked so far.. otherwise crash!!!!!!! if (is.numeric(v$plotx) & is.wholenumber(session$userData$tracks[[id]][["clickCount"]]/2)){ shinyalert(title = "Approximate Position", type = "info", text = paste0("contact between ",round(v$plotx), " and ",round(v$ploty))) abline(h=v$ploty, lty = "dashed") abline(v=v$plotx, lty = "dashed") } } } } } } session$userData$tracks[[id]][["clickCount"]] <- session$userData$tracks[[id]][["clickCount"]]+2+1/1e6 ##destroy the number, so with new coordinates nothing is clicked... }) }) # Worried that v$track wouldn't be distinct for each namespace: but still is!! So no problem. } ) # return(trackData) #the idea was to return this as plotServer is just a function... yet does not yet work.... } server <- function(input, output, session){ ##general Stuff v <- reactiveValues(data = 500) dir.create("~/primeR_dat/tmp/") system(paste0("rm ~/primeR_dat/tmp/*")) volumes <- c(Home = fs::path_home(), "R Installation" = R.home(), getVolumes()()) # Loading chroatin data v$PCSDdata <- f.read.in.PCSD.data(getwd()) v$SMdata <- f.read.in.SM.data(getwd()) ## PrePrimeR Tab start # Loading Files # Load Fasta shinyFileChoose(input = input, "fasta", roots = volumes, filetypes = c('fas', 'FAS', 'fasta', 'FASTA'), restrictions = c("/bin", "/boot", "/dev", "/etc", "/lib", "/lib32", "/lib64", "/opt", "/proc", "/run", "/sbin", "/snap", "/sys", "/usr", "/var", "/root", "/srv", "/tmp", "/mnt", "/lost+found", "/cdrom")) observeEvent(input$fasta, { if (is.integer(input$fasta)) { cat("No fasta file has been selected") } else { v$fastaPath <- parseFilePaths(volumes, input$fasta)$datapath v$chromList <- f.get.chrom.length_new(fastaFile = v$fastaPath) # Create DNAStringSet object for fasta file fasta <- FaFile(v$fastaPath, index=sprintf("%s.fai", v$fastaPath),gzindex=sprintf("%s.gzi", v$fastaPath)) if (!file.exists(paste0(v$fastaPath,".fai"))){indexFa(fasta)} v$out <- scanFa(fasta) fasList <- names(v$out) slistLength <- length(fasList) output$snames <- renderUI({ output <- tagList() for (i in c(1:slistLength)){ output[[i]] <- tagList() output[[i]][[1]] <- checkboxInput(paste0("scheck", i), fasList[i], value = TRUE) output[[i]][[2]] <- textInput(inputId=paste0("sname", i), label=NULL, value=fasList[i]) } output ##BUGGING comment: what does this do here??? should be deleted? }) } }) # Load GFF shinyFileChoose(input = input, "gff", roots = volumes, filetypes = c('gff', 'GFF', 'gff3', 'GFF3'), restrictions = c("/bin", "/boot", "/dev", "/etc", "/lib", "/lib32", "/lib64", "/opt", "/proc", "/run", "/sbin", "/snap", "/sys", "/usr", "/var", "/root", "/srv", "/tmp", "/mnt", "/lost+found", "/cdrom")) observeEvent(input$gff, { if (is.integer(input$gff)) { cat("No gff file has been selected") } else { v$gffPath <- parseFilePaths(volumes, input$gff)$datapath v$gff <- f.read.gff.hierarchical(path = v$gffPath) } }) # Changes based on loading GFF file observe({ if(is.null(v$gff)){ return() } else { gff <- v$gff # Update plot co-ord to first feature v$s <- gff[[2,4]] v$e <- gff[[2,5]] v$chrom <- gff[[2,1]] updateSliderInput(session,"start", value = gff[[2,4]]) updateSliderInput(session,"end", value = gff[[2,5]]) updateTextInput(session, "chrom", value = gff[[2,1]]) # Update feature selector and colour-picker updateCheckboxGroupInput(inputId="gff_features", choices = unique(gff$feature), selected = "gene") colVec <- f.create.col.list(n = length(unique(gff$feature)), transparancy = 1) count <- 0 for(feat in unique(gff$feature)){ count <- count + 1 session$userData$GFF_cols[[feat]] <- list(name = feat) session$userData$GFF_cols[[feat]][["col"]] <- colVec[[count]] } # Set gene as black session$userData$GFF_cols[["gene"]][["col"]] <- "black" # Update RNAseq Features # updateCheckboxGroupInput(session, "RNAFeat", "Select Features:", choices = unique(gff$feature)) # Update GFF mod tab v$nameList <- system(paste0("awk '{ a[$1]++ } END { for (b in a) { print b } }' ", v$gffPath), intern = TRUE) output$anames <- renderUI({ listLength <- length(v$nameList) output <- tagList() for (i in c(1:listLength)){ output[[i]] <- tagList() output[[i]][[1]] <- checkboxInput(paste0("acheck", i), v$nameList[i], value = FALSE) output[[i]][[2]] <- textInput(paste0("aname", i), NULL) } output }) v$featList <- system(paste0("awk '{ a[$3]++ } END { for (b in a) { print b } }' ", v$gffPath), intern = TRUE) updateCheckboxGroupInput(session, "feature", "Select Features:", choices = v$featList) } }) # Colour UI. Generates colours for selected features for Genome Browser. observeEvent(input$gff_features, { gff <- v$gff for(feat in unique(gff$feature)){ removeUI(selector = paste0('#', feat), immediate = TRUE) } count <- 0 for(feat in input$gff_features){ count <- count + 1 insertUI( selector = "#colorPlace", # # is needed before id tag where = "beforeBegin", # new UI placed befsore "place" every time ui = addColorUI(id = feat, col = session$userData$GFF_cols[[feat]][["col"]]) ) addColorServer(id = feat, session = session) } }) # Load description shinyFileChoose(input = input, "desc", roots = volumes, filetypes = c('txt'), restrictions = c("/bin", "/boot", "/dev", "/etc", "/lib", "/lib32", "/lib64", "/opt", "/proc", "/run", "/sbin", "/snap", "/sys", "/usr", "/var", "/root", "/srv", "/tmp", "/mnt", "/lost+found", "/cdrom")) # a safety risk? observeEvent(input$desc, { if (is.integer(input$desc)) { } else { v$desc <- parseFilePaths(volumes, input$desc)$datapath } }) # Show which files are loaded: output$fastaFile <- renderText(v$fastaPath) output$gffFile <- renderText(v$gffPath) output$descFile <- renderText(v$desc) # Save changed fasta file: output$fasMod <- downloadHandler( filename = function(){ # Get file name from loaded fasta file fileNameBase <- f.get.file.name(filepath = v$fastaPath) paste0(getwd(),"/Downloads/", fileNameBase, "_edit.fas") }, content = function(file){ # Get saved DNAStringsSet object out <- v$out fasList <- names(out) slistLength <- length(fasList) # Subset DNAStringsSet chromosomes new <- DNAStringSet() for (k in c(1:slistLength)){ if (input[[paste0("scheck", k)]] == TRUE){ new <- c(new, out[k,]) } } # To rename DNAStringsSet chromosomes newNames <- c() for (j in c(1:slistLength)){ if (input[[paste0("scheck", j)]] == TRUE){ newName <- input[[paste0("sname", j)]] newNames <- c(newNames,newName) } } for (k in c(1:length(newName))){ if (input[[paste0("scheck", k)]] == TRUE){ names(new[k,]) <- newNames[k] } } writeXStringSet(x=new, filepath = file, append=FALSE,compress=FALSE, compression_level=NA, format="fasta") } ) # Sequence Insertion for Fasta shinyFileChoose(input = input, "fileInsert", roots = volumes, filetypes = c('fas', 'FAS', 'fasta', 'FASTA'), restrictions = c("/bin", "/boot", "/dev", "/etc", "/lib", "/lib32", "/lib64", "/opt", "/proc", "/run", "/sbin", "/snap", "/sys", "/usr", "/var", "/root", "/srv", "/tmp", "/mnt", "/lost+found", "/cdrom")) observeEvent(input$fileInsert, { v$fileInsertPath <- parseFilePaths(volumes, input$fileInsert)$datapath }) output$insert <- downloadHandler( filename = function(){ fileNameBase <- f.get.file.name(filepath = v$fastaPath) paste0(getwd(),"/Downloads/", fileNameBase, "_Insert.fas") }, content = function(file){ if(is.integer(input$fileInsert)){ f.insert.seq.in.fasta(inPATH = v$fastaPath, outPATH = file, chrom = input$chromInsert, from = input$posInsert, insertSeq = input$seqInsert) } else { f.insert.large.seq.in.fasta(inPATH = v$fastaPath, insertFile = v$fileInsertPath, outPATH = file, chrom = input$chromInsert, from = input$posInsert) } } ) # Insertion for GFF output$insertGFF <- downloadHandler( filename = function(){ fileNameBase <- f.get.file.name(filepath = v$gffPath) paste0(getwd(),"/Downloads/", fileNameBase, "_Insert.gff") }, content = function(file){ if(is.integer(input$fileInsert)){ f.gff.insertion(gff = v$gff, savePath = file, chrom = input$chromInsert, place = input$posInsert, insert = input$seqInsert, name = input$nameInsert) } else { insert <- as.character(read.table(v$fileInsertPath)) f.gff.insertion(gff = v$gff, savePath = file, chrom = input$chromInsert, place = input$posInsert, insert = insert, name = input$nameInsert) } } ) # Delete fasta sequence output$delete <- downloadHandler( filename = function(){ fileNameBase <- f.get.file.name(filepath = v$fastaPath) paste0(getwd(),"/Downloads/", fileNameBase, "_Deletion.fas") }, content = function(file){ f.delete.seq.in.fasta(inPATH = v$fastaPath, outPATH = file, chrom = input$chromDelete, from = input$startDelete, to = input$endDelete) } ) # Delete for GFF output$deleteGFF <- downloadHandler( filename = function(){ fileNameBase <- f.get.file.name(filepath = v$gffPath) paste0(getwd(),"/Downloads/", fileNameBase, "_Deletion.gff") }, content = function(file){ f.gff.deletion(gff = v$gff, savePath = file, chrom = input$chromDelete, from = input$startDelete, to = input$endDelete) } ) # Invert Fasta output$invert <- downloadHandler( filename = function(){ fileNameBase <- f.get.file.name(filepath = v$fastaPath) paste0(getwd(),"/Downloads/", fileNameBase, "_Invert.fas") }, content = function(file){ f.create.seq.inversion.fasta(inPATH = v$fastaPath, outPATH = file, chrom = input$chromInvert, from = input$startInvert, to = input$endInvert) } ) # Invert for GFF output$invertGFF <- downloadHandler( filename = function(){ fileNameBase <- f.get.file.name(filepath = v$gffPath) paste0(getwd(),"/Downloads/", fileNameBase, "_Invert.gff") }, content = function(file){ f.gff.deletion(gff = v$gff, savePath = file, chrom = input$chromInvert, from = input$startInvert, to = input$endInvert) } ) # Mutate base in Fasta output$mutate <- downloadHandler( filename = function(){ fileNameBase <- f.get.file.name(filepath = v$fastaPath) paste0(getwd(),"/Downloads/", fileNameBase, "_Mutate.fas") }, content = function(file){ if (nchar(input$baseMutate)==(input$endMutate-input$startMutate)+1){ f.mutate.seq.fasta(inPATH = v$fastaPath, outPATH = file, chrom = input$chromMutate, from = input$startMutate, to = input$endMutate, mutSeq = input$baseMutate) } else { shinyalert(title="ERROR", text="The number of mutated bases do not match the spanning of coordinates") } } ) # Transpose sequence in fasta output$transp <- downloadHandler( filename = function(){ fileNameBase <- f.get.file.name(filepath = v$fastaPath) paste0(getwd(),"/Downloads/", fileNameBase, "_Transpose.fas") }, content = function(file){ f.transposition.seq.fasta(inPATH = v$fastaPath, outPATH = file, chrom_orig = input$chromTransp, from_orig = input$startTransp, to_orig = input$endTransp, chrom_dest = input$chromTranspIns, from_dest = input$posTranspIns, inverted = as.character(input$invertTransp)) } ) # Transpose for GFF output$transpGFF <- downloadHandler( filename = function(){ fileNameBase <- f.get.file.name(filepath = v$gffPath) paste0(getwd(),"/Downloads/", fileNameBase, "_Transpose.gff") }, content = function(file){ f.gff.transposition(gff = v$gff, savePath = file, chrom_orig = input$chromTransp, from_orig = input$startTransp, to_orig = input$endTransp, chrom_dest = input$chromTranspIns, from_dest = input$posTranspIns, inverted = as.character(input$invertTransp)) } ) # Reciprocally Translocate sequence in fasta output$trans <- downloadHandler( filename = function(){ fileNameBase <- f.get.file.name(filepath = v$fastaPath) paste0(getwd(),"/Downloads/", fileNameBase, "_Translocate.fas") }, content = function(file){ f.reciporcal.translocation.seq.fasta(inPATH = v$fastaPath, outPATH = file, chromA = input$chromTransA, fromA = input$startTransA, toA = input$endTransA, chromB = input$chromTransB, fromB = input$startTransB, toB = input$endTransB, invertedA = as.character(input$invertTransA), invertedB = as.character(input$invertTransB)) } ) # Translocate for GFF output$transGFF <- downloadHandler( filename = function(){ fileNameBase <- f.get.file.name(filepath = v$gffPath) paste0(getwd(),"/Downloads/", fileNameBase, "_Translocate.gff") }, content = function(file){ f.gff.translocation(gff = v$gff, savePath = file, chromA = input$chromTransA, fromA = input$startTransA, toA = input$endTransA, chromB = input$chromTransB, fromB = input$startTransB, toB = input$endTransB, invertedA = as.character(input$invertTransA), invertedB = as.character(input$invertTransB)) } ) # # GFF seqid/seqname modification # observe({ # if (is.integer(input$gff)) { # cat("No GFF file has been selected") # } else { # v$nameList <- system(paste0("awk '{ a[$1]++ } END { for (b in a) { print b } }' ", v$gffPath), intern = TRUE) # output$anames <- renderUI({ # listLength <- length(v$nameList) # output <- tagList() # for (i in c(1:listLength)){ # output[[i]] <- tagList() # output[[i]][[1]] <- checkboxInput(paste0("acheck", i), v$nameList[i], value = FALSE) # output[[i]][[2]] <- textInput(paste0("aname", i), NULL) # } # output # }) # v$featList <- system(paste0("awk '{ a[$3]++ } END { for (b in a) { print b } }' ", v$gffPath), intern = TRUE) # updateCheckboxGroupInput(session, "feature", "Select Features:", choices = v$featList) # } # }) # Select all features in group checkbox observeEvent(input$selectAllfeat, { updateCheckboxGroupInput(session, "feature", "Select Features", choices = v$eatList, selected = v$featList) }) # Deselect all features in group checkbox observeEvent(input$deselectAllfeat, { updateCheckboxGroupInput(session, "feature", "Select Features", choices = v$featList) }) # Select all features in group checkbox observeEvent(input$selectAllname, { count <- 0 for (name in v$nameList){ count <- count+1 updateCheckboxInput(session, paste0("acheck", count), value = TRUE) } }) # Deselect all features in group checkbox observeEvent(input$deselectAllname, { count <- 0 for (name in v$nameList){ count <- count+1 updateCheckboxInput(session, paste0("acheck", count), value = FALSE) } }) # Save modified GFF output$gffMod <- downloadHandler( filename = function(){ # Get file name from loaded fasta file fileNameBase <- f.get.file.name(filepath = v$gffPath) paste0(getwd(),"/Downloads/", fileNameBase, "_edit.gff") }, content = function(file){ for (feat in input$feature){ system(paste0("awk '$3==\"", as.character(feat) , "\"' '", v$gffPath, "' >> 'temp_prePrimeR.txt'")) } # Subsets newly created file based on selected chromosomes. # nameList <- system(paste0("awk '{ a[$1]++ } END { for (b in a) { print b } }' ", v$pathToGFF), intern = TRUE) cat(file = stderr(), v$nameList) nlistLength <- length(v$nameList) for (j in c(1:nlistLength)){ if (input[[paste0("acheck", j)]] == TRUE){ system(paste0("awk '$1==\"", v$nameList[j], "\"' 'temp_prePrimeR.txt' >> 'temp2_prePrimeR.txt'")) } } # Finally alters chromosome names based on entered names. gffnewName <- c() for (k in c(1:nlistLength)){ if (input[[paste0("acheck", k)]] == TRUE){ gffnewName[k] <- input[[paste0("aname", k)]] } else { gffnewName[k] <- paste0("NA") } } cat(file = stderr(), gffnewName) for (l in c(1:nlistLength)){ if (input[[paste0("acheck", l)]] == TRUE){ system(paste0("awk 'gsub(\"", v$nameList[l], "\", \"", gffnewName[l], "\")' 'temp2_prePrimeR.txt' >> '", file, "'" )) } } # Deletes temporary files. unlink('temp_prePrimeR.txt') unlink('temp2_prePrimeR.txt') } ) # Convert BAM to BigWig shinyFileChoose(input = input, "bam_to_bw", roots = volumes, filetypes = c('bam', 'BAM'), restrictions = c("/bin", "/boot", "/dev", "/etc", "/lib", "/lib32", "/lib64", "/opt", "/proc", "/run", "/sbin", "/snap", "/sys", "/usr", "/var", "/root", "/srv", "/tmp", "/mnt", "/lost+found", "/cdrom")) observeEvent(input$normBW,{v$CovNormBW <- input$normBW})####IS THIS NEEDED??? observeEvent(input$bam2bwConv, { if (is.integer(input$bam_to_bw)) { cat("No BAM file has been selected") shinyalert(text = "No BAM file has been selected", closeOnClickOutside = TRUE, type = "info", size = "m") } else { withProgress(message = 'converting bam to bigwig', style = "notification", { v$pathToBAM <- parseFilePaths(volumes, input$bam_to_bw)$datapath f.bam.to.bw2(bamfile = v$pathToBAM, norm = v$CovNormBW) shinyalert(text = "Conversion completed", closeOnClickOutside = TRUE, type = "info", size = "m") # Issue here will be if names for chromo/feature in diff. column in diff. GFF! ($ indicates column) }) } }) ## PrePrimeR Tab end ## Genome Browser start # Go for start/end co-ord observeEvent(input$go, { v$s <- input$start v$e <- input$end v$chrom <- input$chrom }) observeEvent(input$remPos, { v$rem_s <- v$s v$rem_e <- v$e v$rem_c <- v$chrom }) observeEvent(input$pastPos, { start <- v$rem_s v$s <- start end <- v$rem_e v$e <- end chrom <- v$rem_c v$chrom <- chrom updateSliderInput(session,"start", value = start) updateSliderInput(session,"end", value = end) updateTextInput(session, "chrom", value = chrom) }) # Move right action observeEvent(input$plus, { mover <- (v$e-v$s)*0.1 v$s <- v$s + (mover) v$e <- v$e + (mover) start <- round(v$s) end <- round(v$e) if(start < 1){ updateSliderInput(session, "start", value = 1) } else {updateSliderInput(session,"start", value = start)} updateSliderInput(session,"end", value = end) }) # Move left action observeEvent(input$minus, { mover <- (v$e-v$s)*0.1 v$s <- v$s - (mover) v$e <- v$e - (mover) start <- round(v$s) end <- round(v$e) if(start < 1){ updateSliderInput(session, "start", value = 1) } else {updateSliderInput(session,"start", value = start)} updateSliderInput(session,"end", value = end) }) # Move frame right action: observeEvent(input$frameR, { mover <- (v$e-v$s)*0.95 v$s <- v$s + (mover) v$e <- v$e + (mover) start <- round(v$s) end <- round(v$e) if(start < 1){ updateSliderInput(session, "start", value = 1) } else {updateSliderInput(session,"start", value = start)} updateSliderInput(session,"end", value = end) }) # Move frame left action: observeEvent(input$frameL, { mover <- (v$e-v$s)*0.95 v$s <- v$s - (mover) v$e <- v$e - (mover) start <- round(v$s) end <- round(v$e) if(start < 1){ updateSliderInput(session, "start", value = 1) } else {updateSliderInput(session,"start", value = start)} updateSliderInput(session,"end", value = end) }) observeEvent(input$zoomFac, {v$zoomFac <- input$zoomFac}) # Zoom in action observeEvent(input$zi, { # v$s <- round(v$s + 0.1*(v$e-v$s)) # v$e <- round(v$e - 0.1*(v$e-v$s)) center <- round(mean(c(v$s,v$e))) len <- v$e-v$s newLen <- len/v$zoomFac v$s <- center - 0.5*newLen v$e <- center + 0.5*newLen start <- round(v$s) end <- round(v$e) if(start < 1){ updateSliderInput(session, "start", value = 1) v$s <- 1 } else {updateSliderInput(session,"start", value = start)} updateSliderInput(session, "end", value = end) }) # Zoom out action observeEvent(input$zo, { #v$s <- round(v$s - 0.1*(v$e-v$s)) #v$e <- round(v$e + 0.1*(v$e-v$s)) center <- round(mean(c(v$s,v$e))) len <- v$e-v$s newLen <- len*v$zoomFac v$s <- center - 0.5*newLen v$e <- center + 0.5*newLen start <- round(v$s) end <- round(v$e) if(start < 1){ updateSliderInput(session, "start", value = 1) v$s <- 1 } else {updateSliderInput(session,"start", value = start)} updateSliderInput(session, "end", value = end) }) # # Load additional annotation file # v$add <- NULL # observeEvent(input$addAnno, { # shinyFileChoose(input = input, "addAnno", roots = volumes, filetypes = c('txt'), restrictions = c("/bin", "/boot", "/dev", "/etc", "/lib", "/lib32", "/lib64", "/opt", "/proc", "/run", "/sbin", "/snap", "/sys", "/usr", "/var", "/root", "/srv", "/tmp", "/mnt", "/lost+found", "/cdrom")) # a safety risk? # if (is.integer(input$addAnno)) { # } else { # v$addPATH <- parseFilePaths(volumes, input$addAnno)$datapath # v$add <- read.delim(paste(v$addPATH), header = TRUE) # } # }) observeEvent(input$gffHeight, {v$gffHeight <- as.numeric(input$gffHeight)}) #make it usable everywhere # Go to gene button action DID NOT WORK ANYMORE - I FIXED IT ... the problem is that v$an has no gene name part anymore, to have faster initial loading.... observeEvent(input$goButton, { req(input$geneID) if (!is.null(input$geneID)){ suban <- as.data.frame(v$gff) suban <- suban[suban$feature == "gene",] geneIndex <- grep(input$geneID, suban$attributes) if (length(geneIndex)!=0){ v$s <- suban[geneIndex,"start"]-5e3 # here we define the position with a gene name print(paste0("this is the new start", v$s)) v$e <- suban[geneIndex,"end"]+5e3 v$chrom <- suban[geneIndex,"seqname"] updateSliderInput(session, "start", value = v$s) updateSliderInput(session, "end", value = v$e) updateTextInput(session, "chrom", value = v$chrom) } else {shinyalert(title="Annotation name not found", text="This name cannot be found in the GFF file (case sensitives)")} } }) # Highlight sequence v$light <- NULL observeEvent(input$highlight,{ v$light <- input$searchSeq }) # Cheat to refresh colours on plot observeEvent(input$update, { gff <- v$gff featOI <- input$gff_features # Works but doesn't update on colour changes, have to press an action button i.e. run replot... col_ls <- session$userData$GFF_cols cols <- c() for(i in c(1:length(featOI))){ col <- col_ls[[featOI[i]]]$col cols <- append(cols, col) } colToFeat <- setNames(as.list(cols),featOI) v$colToFeat <- colToFeat ###added this for the pdf output later.... }) # Plot annotation file output$annoContent <- renderPlot({ ## we change here and below (output$anno <- renderUI({....) to be able to adjust plot height dynamically, yet this is not dynamically working since otherwise the plot has to be replotted each time an additional track is added... if(is.null(v$gff)){ return() } else{ # Get selected features and colours gff <- v$gff featOI <- input$gff_features # Works but doesn't update on colour changes, have to press an action button i.e. run replot... col_ls <- session$userData$GFF_cols cols <- c() for(i in c(1:length(featOI))){ col <- col_ls[[featOI[i]]]$col cols <- append(cols, col) } colToFeat <- setNames(as.list(cols),featOI) v$colToFeat <- colToFeat ###added this for the pdf output later.... gff <- gff[gff$feature %in% featOI,] v$gff_sel <- gff[gff$feature %in% featOI,] par(mar = c(5,4,0,2)) ##was c(5,2,0,2) before.. never fitted the par in the track plots???? if ((as.numeric(v$e) - as.numeric(v$s)) >= 5e4 & (as.numeric(v$e) - as.numeric(v$s)) <= 5e5) { f.plot.gff.strand.separated(gff = v$gff_sel,chrom = v$chrom, start = v$s, end = v$e, textShift = 0.25, includeName = TRUE, colToFeat = v$colToFeat) } else if ((as.numeric(v$e) - as.numeric(v$s)) > 5e5) { f.plot.gff.binned(gff = v$gff_sel, chrom = v$chrom, start = v$s, end = v$e, binsize = NULL, colToFeat = v$colToFeat, numBins = 500) } else if ((as.numeric(v$e) - as.numeric(v$s)) < 5e4){ f.plot.gff.detail.strand.separated(gff = v$gff_sel, chrom = v$chrom, start = v$s, end = v$e, textShift = -0.25, fastaPath = v$fastaPath, SeqToHighLight=v$light, arrowHeadLen = 0.02, blockHeight = 0.02, colToFeat = v$colToFeat) } } }) output$anno <- renderUI({ plotOutput("annoContent", height = v$gffHeight, width = get_width()*2/3, dblclick = dblclickOpts(id = "plot_click"), brush = brushOpts(id = "anno_brush", resetOnNew = TRUE)) #here is the clicking activated (not in UI anymore... }) # now with dynamic height of the plot. Could also be applied to the width # Click returns gene info action (if file loaded) observeEvent(input$plot_click, { if(is.null(v$desc)){ return() } else { if(!is.null(input$plot_click)){ click <- input$plot_click x <- round(as.numeric(click$x)) posRange <- (x-3000):(x+3000) #3000 is the minimal distance one needs sub <- v$gff[v$gff[["seqname"]] %in% v$chrom & v$gff[["feature"]] != "exon",] inRange <- sub[sub[["start"]] %in% posRange | sub[["end"]] %in% posRange, ] inRange$name <- getAttributeField(inRange$attributes, "ID") ## should also work if the name has not been defined before hand.... #inRange <- v$an[v$an[["start"]] %in% posRange | v$an[["end"]] %in% posRange & v$an[["feature"]] != "exon" & v$an[["seqname"]] == as.character(input$chrom), ] dist <- as.data.frame(cbind(abs(x-inRange$start), abs(x-inRange$end))) GeneName <- inRange[which.min(apply(dist,1,min)),"name"] #get the rownumber with the minimal value in the apply.. toPrint <- "no information available" # if (!is.na(GeneName)){toPrint <- paste("",GeneName,"",f.retrieve.gene.info(GeneName, path = v$descriptionPATH), sep = "\n")} if (!is.na(GeneName)){toPrint <- paste("","",f.retrieve.gene.info(GeneName, path = v$desc), sep = "\n")} # if (!is.na(GeneName)){toPrint <- f.retrieve.gene.info(GeneName, path = v$descriptionPATH)} baseLink <- paste0("http://arabidopsis.org/servlets/TairObject?type=locus&name=",GeneName) tags$a(href=baseLink) print(tags$a()) shinyalert(title= GeneName, text = HTML(toPrint), closeOnClickOutside = TRUE, html = FALSE, type = "info", size = "m") # HTML(toPrint) } } }) # Resize plot based on brush points (select) observeEvent(input$anno_brush, { # Brush point zoom in limited to 10 bp, otherwise could zoom in infinitely if((input$anno_brush$xmax-input$anno_brush$xmin) > 10){ v$s <- input$anno_brush$xmin v$e <- input$anno_brush$xmax updateSliderInput(session,"start", value = round(v$s)) updateSliderInput(session,"end", value = round(v$e)) } else { v$s <- v$s v$e <- v$e updateSliderInput(session,"start", value = round(v$s)) updateSliderInput(session,"end", value = round(v$e)) } # Need this to clear the brush box on the plot session$resetBrush("anno_brush") }) # Add track function: observeEvent(input$add, { # Reactive inputs needed for tracks start <- reactive(v$s) end <- reactive(v$e) rpm <- reactive(input$rpm) setYlim <- reactive(input$setYlim) mC_context <- reactive(input$mC_context) siRNA_size <- reactive(input$siRNA_size) HiCtype <- reactive(input$HiCtype) VP <- reactive(input$VP) binSize <- reactive(input$binSize) setRef <- reactive(input$setRef) numTracks <- reactive(numTracks) fas <- reactive(v$fas) chromList <- reactive(v$chromList) global <- reactive(input$global) g_ylim <- reactive(input$g_ylim) chrom <- reactive(v$chrom) # Id and namespace created for individual track new_id <- paste("Track", input$add, sep = "") # Key line for keeping distinct namespaces for every track added. Note input$add is a counter as is! (first new_id = Track1) ns <- NS(new_id) session$userData$tracks[[new_id]] <- list(name = new_id) NewNumTracks <- length(names(session$userData$tracks)) ## needs to be made reactive somehow but this gives an error (see below).. possible solution: Making it an input before????? numTracks <- NewNumTracks updateTextInput(inputId = "numTracks", value = numTracks) # numTracks <- reactive(numTracks) #### gives error... yet the the first plot is then not rescaling only the one added.. plots are not replotted.... ent <- as.numeric(paste0(input$add)) # if (ent == 1){shinyalert(title="INFO", text="For displaying genomics data at more than 50kb a bigwig file is required \n This file can be generated from a bam file in the sevice section")} v$id_list[[ent]] <- paste0(new_id) # New tab appended with Track name appendTab(inputId = "tabs", tabPanel(paste(new_id), selectInput(ns("choice"), "Choose File Type", choices = c("sRNA", "mRNA", "mC", "HiC", "Chromatin State"), width = "40%"), uiOutput(ns("place3")) )) # Add connected plot with same id insertUI( selector = "#place2", where = "beforeBegin", ui = plotUI(id = new_id, numTracks = numTracks) ) addServer(new_id, NumTracks = v$tracks) plotServer(new_id, start, end, chrom, global, g_ylim, ls = ls, fas, chromList, PCSDdata = v$PCSDdata, SMdata = v$SMdata)# plotServer works if here but not if within addServer. Also can't be written as start(), seen as function... #is plot server a function? can it return something? Here one could return the data for the download plot! }) # Removes currently selected track and associated plot observeEvent(input$remove, { session$userData$tracks <- session$userData$tracks[names(session$userData$tracks) != input$tabs] removeTab(inputId = "tabs", target = input$tabs) removeUI(selector = paste0("#", input$tabs, "-plot")) }) # Download sequence file of selected region # observeEvent(input$fasDown, { # pathToGen <- parseFilePaths(volumes, input$fasta)$datapath # x <- character(0) # if(length(pathToGen)){##needed in case no fasta file has been loaded # dirIndex <- gregexpr("/",pathToGen)[[1]][length(gregexpr("/",pathToGen)[[1]])] # dir <- substr(pathToGen,1,dirIndex) # newFilePath <- paste0(dir, input$saveFasta) # #f.get.sequence.file.fasta(infile = pathToGen, outfile = newFilePath, chrom = v$chrom, start = v$s, end = v$e) # f.get.seq.file.fasta(inPATH = pathToGen, outPATH = newFilePath, chrom = v$chrom, from = v$s, to = v$e) # } else { # shinyalert(title="WARNING", text="no fasta file has been loaded", type = "error") # } # }) #new fasta download.. does not need text input for file name.... output$fasDown <- downloadHandler( filename = function(){ filenameBase <- f.get.file.name(filepath = v$fastaPath) paste0(getwd(),"/Downloads/", filenameBase,"_",v$chrom,":",v$s,"-",v$e,".fas") }, content = function(file){ f.get.seq.file.fasta(inPATH = v$fastaPath, outPATH = file, chrom = v$chrom, from = v$s, to = v$e) } ) ########### Download as pdf action: will need some figuring out: needs replotting...##### HERE WWE GO output$down <- downloadHandler( filename = function() { paste("primeRplot_", Sys.Date(), ".pdf", sep="") }, content = function(file) { Tracks <- names(session$userData$tracks) print(paste("There are ", Tracks, " in the download part recognized")) pdf(file, width=14) par(mfrow = c(length(Tracks)+1,1),mar = c(0,4,0,2))###this is a problem when we remove a track, the info is not deleted from the list... one could just do with ls and grep the Tracks.... if (length(v$gff_sel)>0){ if ((as.numeric(v$e) - as.numeric(v$s)) >= 5e4 & (as.numeric(v$e) - as.numeric(v$s)) <= 5e5) { f.plot.gff.strand.separated(gff = v$gff_sel,chrom = v$chrom, start = v$s, end = v$e, textShift = 0.25, includeName = TRUE, colToFeat = v$colToFeat) } else if ((as.numeric(v$e) - as.numeric(v$s)) > 5e5) { f.plot.gff.binned(gff = v$gff_sel, chrom = v$chrom, start = v$s, end = v$e, binsize = NULL, colVec = NULL, numBins = 500) } else if ((as.numeric(v$e) - as.numeric(v$s)) < 5e4){ f.plot.gff.detail.strand.separated(gff = v$gff_sel, chrom = v$chrom, start = v$s, end = v$e, textShift = -0.25, arrowHeadLen = 0.02, blockHeight = 0.02, colToFeat = colToFeat) } #f.plot.gff.anno_detail(chrom = v$chrom, start = v$s, end = v$e, gff = v$gff, label = TRUE) } for (track in Tracks){ data <- session$userData$tracks[[track]] #print(v$chromList) this chromlist does likely not work anymore... #f.track.plotting.wrapper(chrom = v$chrom, start = v$s, end = v$e, data=data, chromList = v$chromList) f.track.plotting.wrapper_2(chrom = v$chrom, start = v$s, end = v$e, data=data) } # if(session$userData$tracks[[Tracks[1]]]$type == "sRNA"){### sRNA plotting # p <- f.reads.extract.minimal(chrom = input$chrom, start = v$s, end = v$e, bamPATHin = session$userData$tracks[[Tracks[1]]]$fileNames, threads = 4) # if ((as.numeric(v$e) - as.numeric(v$s)) > 5e4){ # # When get onto ylim issue: NULL = ylim just determined by data, can set it to reactive based on input later. # # Issue with binned plotters: 'no lines available in input' error: can't find intermediate file I think. # f.binned.plotter.sRNA(inTAB = p, binsize = NULL, start = start(), end = end(), sizes = input$siRNA_size, xlim = c(start(), end()), ylimit = session$userData$tracks[[Tracks[1]]]$ylim, main = NULL, rpm = FALSE, TotLibReads = track_info_ls[["libsize"]][["bam"]]) # } else { # tmp <- f.coverage.plotter.sRNA(inDAT = p, stranded = TRUE, sizes = c(21,22,23,24), rpm = FALSE, TotLibReads = track_info_ls[["libsize"]][["bam"]], start = v$s, end = v$e, ylim = session$userData$tracks[[Tracks[1]]]$ylim, title = "title remove in server part", normFac = NULL) # } # # # renderPlot for mRNA: not working, Na/NaN argument error for coverage plotter (same issues as above for binned plotter) # } dev.off() } ) ########## Download as pdf action: will need some figuring out: needs replotting...##### HERE WWE FINITO ## FISH Tab # Select Working Directory shinyDirChoose(input = input, "work", roots = volumes, restrictions = c("/bin", "/boot", "/dev", "/etc", "/lib", "/lib32", "/lib64", "/opt", "/proc", "/run", "/sbin", "/snap", "/sys", "/usr", "/var", "/root", "/srv", "/tmp", "/mnt", "/lost+found", "/cdrom")) observeEvent(input$work, { if (is.integer(input$work)) { cat("No working directory has been selected") } else { v$workDirPATH <- parseDirPath(volumes, input$work) # Can't have $datapath } }) # Creates input boxes for the number of additional settings wanted for primer3. K <- reactive({input$settings}) observe({ if (input$settings > 0){ output$SetInput <- renderUI({ options <- f.list.primer3.options() NoS <- K() S <- sapply(1:NoS, function(i){paste0("setting", i)}) V <- sapply(1:NoS, function(i){paste0("value", i)}) output <- tagList() for(i in seq_along(1:NoS)){ output[[i]] <- tagList() output[[i]][[1]] <- selectInput(inputId = S[i], label = strong(paste("Additonal Settings", i)), choices = options, selected = options[1], width = "400px") output[[i]][[2]] <- numericInput(inputId = V[i], strong(paste("Value", i)), 0, width = "80px") } output }) } }) # Upon pressing submit button, settings template is edited with the desired additional settings. observeEvent(input$submit, { filePath <- file.path(getwd(), "primer3/template_edit") settingsfile <- readLines(filePath) no <- K() if (no > 0){ # Read in the settings file for Primer3. This can't be hard coded like it is... # Add settings from input from 'additional settings'. Doesn't work if 0? for(i in c(1:no)){ linenum <- reactive({grep(input[[paste0("setting", i)]], settingsfile)}) # Has to be done with input[[paste0("setting", i)]], can't use paste0("input$setting",i)? settingsfile[linenum()] <- paste(substr(settingsfile[linenum()], 1, regexpr('=',settingsfile[linenum()])), input[[paste0("value", i)]], sep='') } } # Add in settings from 'mandatory' settings settingsfile[10] <- paste(substr(settingsfile[10],1,regexpr('=',settingsfile[10])), input$min_prod,"-",input$max_prod, sep='') settingsfile[24] <- paste(substr(settingsfile[24],1,regexpr('=',settingsfile[24])), input$min_GC, sep='') settingsfile[28] <- paste(substr(settingsfile[28],1,regexpr('=',settingsfile[28])), input$max_GC, sep='') settingsfile[36] <- paste(substr(settingsfile[36],1,regexpr('=',settingsfile[36])), input$min_Tm, sep='') settingsfile[40] <- paste(substr(settingsfile[40],1,regexpr('=',settingsfile[40])), input$max_Tm, sep='') # Runs primeR functions: creating working directory, create FISH probes, BLASTs primers. workDirPATH <- req(v$workDirPATH) pathToGen <- v$fastaPath # genome <- req(v$FISHgen) cat(file = stderr(), workDirPATH) workingDirList <- f.create.working.directory(baseDir = paste0(workDirPATH)) # Changing genome to the fastaFile path here f.generate.FISH.probes(c(input$name, input$chromProbe, input$pos), workDir = workingDirList, genome = pathToGen, searchRadius = input$rad , stepSize = input$step, p3File = settingsfile) blastDB <- f.create.BLAST.DB(fastaPath = pathToGen, workDir = workingDirList) f.blast.primers.FISH(workDir = workingDirList, sample = input$name, maxMismatch = input$maxMM, maxMMinEnd = input$maxMMend, maxPrimerDist = input$maxPDist, maxAlignLen = input$maxAlign, probeMM = input$probeMM, probeAL = input$probeAlign, allowExactHits = input$exHit, genome = pathToGen, blastDB = blastDB, checkProbeSpecificity = input$probeSpec) output$gel <- renderPlot({ f.run.gel.FISH(workDir=workingDirList, ROI= input$name, agarose = input$agar, voltage = input$volt, time = input$time) }) finalPrimers <- read.table(paste0(workDirPATH, '/R_prime_output/FISH/', input$name, '/BlastOUT/', input$name, '_blastedPrimer_ApE.txt')) colnames(finalPrimers) <- c("Name", "Primer Sequence") output$primer <- renderTable({finalPrimers}) }) ## Chromatin State server elements # Load data based on choice observe({ check <- grepl("PCSD", input$data, fixed = TRUE) if (isTRUE(check)){ v$stateDF <- v$PCSDdata } else { v$stateDF <- v$SMdata } }) # If have single co-ord: will run this graph generator observeEvent(input$go1, { finalDF <- f.subset.data(input$chromS, input$startS, input$endS, v$stateDF) output$relative <- renderPlot({ f.plot.relative.chromatin.states(finalDF) }) output$table <- renderDT(finalDF, options = list(scorllX = TRUE), rownames = TRUE, selection = "single") }) # If look for a specific gene; observeEvent(input$chromGeneGo, { if(is.null(v$gff)){ shinyalert(title="No GFF Loaded", text = "Load GFF file to look at genes.") } else { if (!is.null(input$chromGene)){ suban <- as.data.frame(v$gff) suban <- suban[suban$feature == "gene",] geneIndex <- grep(input$chromGene, suban$attributes) if (length(geneIndex) != 0){ start <- suban[geneIndex,"start"] end <- suban[geneIndex,"end"] chrom <- suban[geneIndex,"seqname"] chrom <- tolower(chrom) finalDF <- f.subset.data(as.character(chrom), as.integer(start), as.integer(end), v$stateDF) output$relative <- renderPlot({ f.plot.relative.chromatin.states(finalDF) }) output$table <- renderDT(finalDF, options = list(scorllX = TRUE), rownames = TRUE, selection = "single") } else {shinyalert(title="Annotation name not found", text="This name cannot be found in the GFF file (case sensitives)")} } else {shinyalert(title="No Gene Input", text="Enter Gene name to use this feature")} } }) # Load file of a group of regions shinyFileChoose(input = input, "file", roots = volumes, filetypes = c('txt'), restrictions = c("/bin", "/boot", "/dev", "/etc", "/lib", "/lib32", "/lib64", "/opt", "/proc", "/run", "/sbin", "/snap", "/sys", "/usr", "/var", "/root", "/srv", "/tmp", "/mnt", "/lost+found", "/cdrom")) observeEvent(input$file, { if (is.integer(input$file)) { cat("No file selected") } else { # Saves filePath of loaded file v$pathToFile <- parseFilePaths(volumes, input$file)$datapath } }) # If load file with multiple co-ord runs this graph generator observeEvent(input$go2, { output$relative <- renderPlot({ f.compare.ROI(v$pathToFile, v$stateDF) }) }) # If have two groups of co-ords runs this graph generator shinyFileChoose(input = input, "file1", roots = volumes, filetypes = c('txt'), restrictions = c("/bin", "/boot", "/dev", "/etc", "/lib", "/lib32", "/lib64", "/opt", "/proc", "/run", "/sbin", "/snap", "/sys", "/usr", "/var", "/root", "/srv", "/tmp", "/mnt", "/lost+found", "/cdrom")) observeEvent(input$file1, { if (is.integer(input$file1)) { cat("No file selected") } else { # Saves filePath of loaded file v$pathToFile1 <- parseFilePaths(volumes, input$file1)$datapath } }) shinyFileChoose(input = input, "file2", roots = volumes, filetypes = c('txt'), restrictions = c("/bin", "/boot", "/dev", "/etc", "/lib", "/lib32", "/lib64", "/opt", "/proc", "/run", "/sbin", "/snap", "/sys", "/usr", "/var", "/root", "/srv", "/tmp", "/mnt", "/lost+found", "/cdrom")) observeEvent(input$file2, { if (is.integer(input$file2)) { cat("No file selected") } else { # Saves filePath of loaded file v$pathToFile2 <- parseFilePaths(volumes, input$file2)$datapath } }) observeEvent(input$go3, { output$relative <- renderPlot({ f.plot.group.state(v$pathToFile1, v$stateDF) }) output$relative2 <- renderPlot({ f.plot.group.state(v$pathToFile2, v$stateDF) }) }) # Generates table of co-ordinates for regions with similar states to the selected ROI. observeEvent(input$go4, { withProgress(message = "searching for candidates", style = "notification", { mid <- input$endS-input$startS/2 + input$startS v$candTable <- reactive({f.find.similar.state(chrom = input$chromS, start = input$startS, end = input$endS, mid = mid, stateDF = v$stateDF, searchRange = input$range, buffer = input$buff, searchSize = input$size, ln = input$ln, step = 100, maxState = input$state, lim = input$lim)}) if(nrow(v$candTable()) > 0){ output$candidate <- renderDT(v$candTable(), options = list(scorllX = TRUE), rownames = TRUE, selection = "single") } else { output$alert <- renderText("No candiates found. Adjust parameters and try again.") } }) }) # When click on table of candidates generates plot of selected candidate! output$candrel <- renderPlot({ validate(need(input$candidate_rows_selected, "")) candRow <- input$candidate_rows_selected data <- v$candTable()[candRow,] candDF <- f.subset.data(input$chromS, data[,1], data[,2], v$stateDF) f.plot.relative.chromatin.states(candDF) }) # RNAseq Tab # Load Hierachy File shinyFileChoose(input = input, "hierachLoad", roots = volumes, filetypes = c('txt'), restrictions = c("/bin", "/boot", "/dev", "/etc", "/lib", "/lib32", "/lib64", "/opt", "/proc", "/run", "/sbin", "/snap", "/sys", "/usr", "/var", "/root", "/srv", "/tmp", "/mnt", "/lost+found", "/cdrom")) observeEvent(input$hierachLoad, { if (is.integer(input$hierachLoad)) { cat("No hierarchy file has been selected") } else { v$hierachPath <- parseFilePaths(volumes, input$hierachLoad)$datapath v$hierach <- readRDS(v$hierachPath) } }) # Create a full hierachy file observeEvent(input$hierach, { if(is.null(v$gff) == FALSE){ gff <- v$gff progress <- shiny::Progress$new() progress$set(message = "analyzing hierarchy", value = 0) # Close the progress when this reactive exits (even if there's an error) on.exit(progress$close()) # Create a callback function to update progress. # Each time this is called: - If `value` is NULL, it will move the progress bar 1/length(unique(gff$feature) of the remaining distance. If non-NULL, it will set the progress to that value. updateProgress <- function(value = NULL, detail = NULL) { if (is.null(value)) { value <- progress$getValue() value <- value + (progress$getMax() - value) / (length(unique(gff$feature))) #after the division says in how many steps the progress bar increases } progress$set(value = value, detail = detail) } v$hierach <- f.get.hierarchy.from.gff(gff=gff, chomSel = "Chr2",updateProgress) #### here we should allow the option to choose the chromosomes... }else{ print("No GFF loaded!") } }) output$hierachSave <- downloadHandler( filename = function(){ fileNameBase <- f.get.file.name(filepath = v$gffPath) paste0(getwd(),"/Downloads/", fileNameBase, "_Hierach.txt") }, content = function(file){ # Saved as non-human readable file saveRDS(v$hierach, file = file)##non-human readable RDS file not containing a gff with a hierarchy column!!!!!!!! } ) # Load RNAseq bam files shinyFileChoose(input = input, "RNAFiles", roots = volumes, filetypes = c('bam'), restrictions = c("/bin", "/boot", "/dev", "/etc", "/lib", "/lib32", "/lib64", "/opt", "/proc", "/run", "/sbin", "/snap", "/sys", "/usr", "/var", "/root", "/srv", "/tmp", "/mnt", "/lost+found", "/cdrom")) observeEvent(input$RNAFiles, { if (is.integer(input$RNAFiles)) { cat("No file selected") } else { # Saves filePath of loaded file v$RNAFiles <- parseFilePaths(volumes, input$RNAFiles)$datapath shinyalert(title="FILES LOADED", text=paste(v$RNAFiles, collapse = "\n")) } }) # Modifies UI based on simple GFF or hierachy. output$RNAfeatures <- renderUI({ gff <- v$gff if(input$useHierach == FALSE){ dropdownButton(tags$style(".fa-cog {color:#ee2c2c}"),tags$h3("feature selection"),inputId = "mydropdown",label = "feature selection",icon = icon("list-check"), width = "400px",status = "primary",circle = FALSE, checkboxGroupInput(inputId = "RNAFeat", "Select GFF Features", choices = unique(gff$feature), selected = "mRNA") ) } else { tagList( tags$head( tags$script( HTML(' $(document).ready(function() { var selectedNodes = []; $("#myTree").on("select_node.jstree", function (e, data) { var selectedNodeId = data.node.id; // Check if the node is already selected var isSelected = selectedNodes.includes(selectedNodeId); // If the node is already selected, deselect it if (isSelected) { var index = selectedNodes.indexOf(selectedNodeId); if (index > -1) { selectedNodes.splice(index, 1); } } // If the node is not already selected, select it and deselect parent and child nodes else { // Deselect parent and child nodes var parentNode = data.instance.get_parent(selectedNodeId); var childNodes = data.instance.get_children(selectedNodeId); data.instance.deselect_node(parentNode); data.instance.deselect_node(childNodes); // Select only the clicked node selectedNodes.push(selectedNodeId); } }); $("#myTree").on("deselect_node.jstree", function (e, data) { var deselectedNodeId = data.node.id; // Remove deselected node from selectedNodes array var index = selectedNodes.indexOf(deselectedNodeId); if (index > -1) { selectedNodes.splice(index, 1); } }); }); ') ) ), h4("Select and search in the tree of features"), shinyTree("myTree", multiple = TRUE, checkbox = TRUE,theme = "proton", stripes = TRUE, search = TRUE) ) } }) observeEvent(input$useHierach,{ gff <- v$gff if(input$useHierach == TRUE){ output$myTree <- renderTree({ v$hierach[["hierarchy"]] }) } }) observeEvent(input$myTree,{ if(input$useHierach == TRUE){ selectedFeatures <- get_selected(input$myTree, "slices") if (length(selectedFeatures)>0){ selectionDF <- rrapply(selectedFeatures, how = "melt") } v$hierarchySelection <- selectedFeatures } else { # Update RNAseq Features updateCheckboxGroupInput(session, "RNAFeat", "Select Features:", choices = unique(v$gff$feature), selected = "mRNA") } }) observeEvent(input$myTree, { selectedFeatures_lsStyle <- get_selected(input$myTree, "slices") if (length(selectedFeatures_lsStyle)>0){ selectionDF <- rrapply(selectedFeatures_lsStyle, how = "melt") gff_sel <- data.frame(matrix(vector(), 0, ncol(v$gff)+1,dimnames=list(c(), c(colnames(v$gff),"nodes"))),stringsAsFactors=F) for (p in c(1:nrow(selectionDF))){ catName <- as.vector(selectionDF[p,2:(ncol(selectionDF)-1)]) catName <- catName[!is.na(catName)] printCatName <- paste0(catName, collapse = " -> ") dfToAdd <- v$gff[as.numeric(v$hierach[["gff_cat"]][[paste0(catName, collapse = "")]]),] dfToAdd$nodes <- printCatName gff_sel <- rbind(gff_sel, dfToAdd) #here we add to a empty df v$gff_sel <- gff_sel #output$selectionCheck <- renderText({ # paste(unique(gff_sel$nodes),collapse = "\n") #}) } } }) observeEvent(input$selectionCheck, { if (!is.null(v$gff_sel)){ shinyalert(title="Selected Features", text=paste(unique(v$gff_sel$nodes),collapse = "\n")) } else { shinyalert(title="Selected Features", text="no features has been selected") } }) # Load count data made previously shinyFileChoose(input = input, "countLoad", roots = volumes, filetypes = c('txt'), restrictions = c("/bin", "/boot", "/dev", "/etc", "/lib", "/lib32", "/lib64", "/opt", "/proc", "/run", "/sbin", "/snap", "/sys", "/usr", "/var", "/root", "/srv", "/tmp", "/mnt", "/lost+found", "/cdrom")) observeEvent(input$countLoad, { if (is.integer(input$countLoad)) { cat("No file selected") } else { # Saves filePath of loaded file v$countDataPath <- parseFilePaths(volumes, input$countLoad)$datapath v$countData <- read.table(v$countDataPath, sep = "\t", header = TRUE, stringsAsFactors = FALSE) sampleColumns <- colnames(v$countData)[7:length(colnames(v$countData))] updateCheckboxGroupInput(session, "RNAConFiles", "Select Controls:", choices = sampleColumns, inline = FALSE) updateCheckboxGroupInput(session, "RNASampFiles", "Select Treatment:", choices = sampleColumns, inline = TRUE) } }) # Run count function on RNAseq data observeEvent(input$count, { gff <- v$gff selected_features <- input$RNAFeat if(input$useHierach == TRUE){####BUGGING COMMENT: here we are still at work gff <- v$gff_sel selected_features <- unique(gff$feature) } if (is.null(v$gff)){ shinyalert(title="!TROUBLE!", text="please load a gff file in the file manipulation section", type = "error") } else if (length(v$RNAFiles)<2){ shinyalert(title="!TROUBLE!", text="please load at least two bam files", type = "error") } else { v$countData <- f.RNAseq.count(gff = gff, features = selected_features, files = v$RNAFiles, isPairedEnd = input$RNA_isPairedEnd, strandSpecific = input$RNA_strandSpecific, largestOverlap = input$RNA_largestOverlap, minOverlap = input$RNA_minOverlap, countMultiMappingReads = input$RNA_countMultiMappingReads, fraction = input$RNA_fraction, splitOnly = input$RNA_splitOnly, primaryOnly = input$RNA_primaryOnly, ignoreDup = input$RNA_ignoreDup, requireBothEndsMapped = input$RNA_requireBothEndsMapped, minMQS = input$RNA_minMQS, minFragLength = input$RNA_minFragLength, maxFragLength = input$RNA_maxFragLength, countChimericFragments = input$RNA_countChimericFragments, nthreads = input$RNA_nthreads ) ####BUGGING COMMENT: Ideally comes with real progress bar.... there is all this text output of the function, maybe print this in the main screen? shinyalert(title="Hurray", text="count table is finished") sampleColumns <- colnames(v$countData)[7:length(colnames(v$countData))] updateCheckboxGroupInput(session, "RNAConFiles", "Select Features:", choices = sampleColumns) updateCheckboxGroupInput(session, "RNASampFiles", "Select Features:", choices = sampleColumns) } }) # Save count data output$countDown <- downloadHandler( filename = function(){ paste0(getwd(),"/Downloads/countData.txt")####BUGGING COMMENT: that is not ideal... }, content = function(file){ write.table(x = v$countData, file = file, quote = FALSE) } ) observeEvent(input$RNAgo, { if (length(input$RNAConFiles)<1 | length(input$RNASampFiles)<1){ shinyalert(title="TROUBLE", text="no controls or samples selected", type = "error") } else if (is.null(v$countData)){ shinyalert(title="TROUBLE", text="no count data available", type = "error") } else { v$res <- f.RNAseq.analysis(counts = v$countData, conFiles = input$RNAConFiles, sampFiles = input$RNASampFiles, minCount = input$RNAminCount, minTotalCount = input$RNAminCountTotal) res <- v$res v$sigDEGs <- res[res$adjP < input$RNApThresh & abs(res$logFC) > input$RNAFC, ] output$RNAtable <- renderDT(v$sigDEGs, options = list(scorllX = TRUE), rownames = TRUE, selection = "single") } }) rangesVolcano <- reactiveValues(x = NULL, y = NULL)###brushing xlim and ylim observeEvent(input$volcano_brush, { brush <- input$volcano_brush if (!is.null(brush)) { rangesVolcano$x <- c(brush$xmin, brush$xmax) rangesVolcano$y <- c(brush$ymin, brush$ymax) } else { rangesVolcano$x <- NULL rangesVolcano$y <- NULL } }) output$volcano1 <- renderPlot({ res <- v$res if (!is.null(res)){ sigDEGs <- v$sigDEGs if(nrow(res)>0){ f.RNAseq.plot(res = res, pThresh = input$RNApThresh) } s <- input$RNAtable_rows_selected if(length(s) > 0){points(sigDEGs[[s, "logFC"]],-log10(sigDEGs[s,"adjP"]), ylim = c(0,5), col = "yellow", pch =16, cex = 1.5)}####this is not really working.... } }) output$DEDown <- downloadHandler( filename = function(){ paste0(getwd(),"/Downloads/DEtable.txt")####BUGGING COMMENT: that is not ideal... }, content = function(file){ write.table(x = v$sigDEGs, file = file, quote = FALSE) } ) selected <- reactiveVal() observeEvent(input$volcano_click, { res <- v$res res$adjP <- -log10(res$adjP) # pointSel <- nearPoints(res, input$volcano_click, allRows = TRUE, xvar="logFC", yvar="adjP", threshold = 5, maxpoints = 1)$selected_ pointSel <- nearPoints(res, input$volcano_click, allRows = FALSE, xvar="logFC", yvar="adjP", threshold = 5, maxpoints = 1) # x <- input$volcano_click$x # res_click_sel <- v$res[which.min(abs(v$res$logFC - x)),] # res_click_sel <- v$res[pointSel,] # selected(res_click_sel) selected(pointSel) }) output$volcano2 <- renderPlot({ res <- v$res if (!is.null(res)){ sel <- selected() sigDEGs <- v$sigDEGs if(nrow(res)>0){ f.RNAseq.plot(res = res, pThresh = input$RNApThresh, xlim = rangesVolcano$x, ylim = rangesVolcano$y) if(!is.null(sel)){ points(sel[1,"logFC"],as.numeric(sel[1,"adjP"]), col = "green", pch = 16) #no -log10 here as this was added to res above in the observeEvent text(sel[1,"logFC"],as.numeric(sel[1,"adjP"]), label = sel[1,"ID"]) v$plantURL <- paste0("http://plants.ensembl.org/Arabidopsis_thaliana/Gene/Summary?g=",sel[1,"ID"]) } } s <- input$RNAtable_rows_selected if(length(s) > 0){points(sigDEGs[[s, "logFC"]],-log10(sigDEGs[s,"adjP"]), ylim = c(0,5), col = "yellow", pch =16, cex = 1.5)} } }) observeEvent(input$additionalGeneInfo,{###I thought to put this to connect to a URL if possible.... # shinyalert(html = TRUE, text = tagList( # textOutput(v$plantURL) # )) }) observeEvent(input$moveToHit, { s <- input$RNAtable_rows_selected if(length(s) > 0){ gene <- v$sigDEGs[[s, "ID"]] gff <- v$gff subgff <- gff[gff$feature == "gene",] geneIndex <- grep(gene, subgff$attributes) v$s <- subgff[geneIndex,"start"] - 5e3 v$e <- subgff[geneIndex,"end"] + 5e3 v$chrom <- subgff[geneIndex,"seqname"] updateSliderInput(session,"start", value = v$s) updateSliderInput(session,"end", value = v$e) updateTextInput(session, "chrom", value = v$chrom) } }) observeEvent(input$GOgroup,{ if (input$GOgroup != "none" & curl::has_internet()){ v$MART_info <- f.find.mart.genomes(input$GOgroup) updateSelectInput(inputId = "GOspecies", choices = v$MART_info$mart_genomes) } }) observeEvent(input$goGO,{ if (is.null(v$sigDEGs) | is.null(v$MART_info$mart_name) | is.null(input$GOspecies) | is.null(v$MART_info$host)){ shinyalert(title="TROUBLE", text="either no DE analysis is available or GO specifications are missing", type = "error") } else { signGenes <- v$sigDEGs[order(abs(v$sigDEGs$logFC), decreasing = TRUE),] GOres <- f.perform.GO.analysis(biomart = v$MART_info$mart_name, dataset = input$GOspecies, host = v$MART_info$host, DEGs = signGenes) if (is.null(GOres)) { shinyalert(title="TROUBLE", text="gene names do not match. did you select the correct mart and species?", type = "error") } else { v$GOres <- GOres } } }) observeEvent(input$GOcat,{ if (!is.null(v$GOres)){ updateSelectInput(inputId = "GOterm", choices = c("all",v$GOres[[input$GOcat]][,"Term"])) } }) output$GOplot <- renderPlot({ if (!is.null(v$GOres) & !is.null(input$GOcat)){ if (input$GOterm == "all"){ f.GO.plotter(GOinput = v$GOres, GOcat = input$GOcat, DEG = v$sigDEGs) } else { f.GO.plotter.highlight(GOinput = v$GOres, GOcat = input$GOcat, DEG = v$sigDEGs, GOterm = input$GOterm) } } }) output$GOtable <- renderDT(v$GOres[[input$GOcat]], options = list(scorllX = TRUE), rownames = TRUE, selection = "single") output$GODown <- downloadHandler( filename = function(){ paste0(getwd(),"/Downloads/GOtable.txt")####BUGGING COMMENT: that is not ideal... }, content = function(file){ write.table(x = v$sigDEGs, file = file, quote = FALSE) } ) } source(paste0(getwd(),"/ShinyFunctions.R")) shinyApp(ui, server) # runGadget(ui, server, viewer = browserViewer(browser = getOption("browser")))