app.R

library(shiny)
library(shinydashboard)
library(data.table)
library(readr)
library(rintrojs)
library(shinyjs)
library(wilson)
library(RJSONIO)
library(rtracklayer)
library(kutils)

#
# Server options
#

# app working directory
wd <- getwd()

# nginx port
port <- NULL

# Allow the server to print messages to the console
uropa_logging <- FALSE

# Redirect stdout to stderr when run on a server. This will print all output into the log file.
uropa_redirect_stdout <- FALSE

# Enable logging of reactive events, which can be viewed later with the showReactLog function. This incurs a substantial performance penalty and should not be used in production.
uropa_enable_reactive_event_logging <- FALSE

# Enable automatic reload of files that change during the runtime. All connected Shiny sessions will be reloaded. This incurs a substantial performance penalty and should not be used in production.
uropa_enable_auto_reload <- TRUE

# Customize the patterns for files that shiny will monitor for automatic reloading
uropa_auto_reload_pattern <- ".*\\.(r|html?|js|css|png|jpe?g|gif)$"

# Sets the auto reload polling interval in milliseconds
uropa_auto_reload_interval <- 3000

# Sets the maximum file upload size in mb
uropa_max_upload_size <- 5000

if (uropa_logging) options(shiny.trace = TRUE)
if (uropa_enable_reactive_event_logging) options(shiny.reactlog = TRUE)
if (uropa_enable_auto_reload) {
  options(shiny.autoreload = TRUE)
  options(shiny.autoreload.pattern = uropa_auto_reload_pattern)
  options(shiny.autoreload.interval = uropa_auto_reload_interval)
}
options(shiny.maxRequestSize = uropa_max_upload_size * 1024^2)

# Redirect stdout to stderr when running on server. All output will end up in the log file
if (uropa_redirect_stdout & !interactive() ) {
  sink(stderr(), type="output")
}

#
# UROPA application logic
#

# Number of threads used during UROPA analysis
thread_num <- 2

# Set directory to store uropa results
result_location <- "UROPA_RESULT"

# set the folder location of all gtf files
gtf_file_location <- "ref_gtfs"

# set gtf file list file name
gtf_list_file <- "gtflist_copy.tsv"

# Set files used for demo run 
demo_dir <- "demo_files"
demo_gtf <- "gencode.v19.annotation_reduced.gtf"
demo_bed <- "ENCFF001VFA.peaks.bed"
demo_config <- "config.json"


message(getwd())
# read file containing list of all gtf file names
gtf_table <- fread(input = file.path(gtf_file_location, gtf_list_file), header = FALSE)
# create named list of gtf_list to be used in selectInput
gtf_list <- gtf_table[[2]]
names(gtf_list) <- gtf_table[[1]]

whitelist <- c("gene_type", "gene_status", "transcript_type", "transcript_status", "level", "gene_source", "gene_biotype", "transcript_biotype", "gene_version", "transcript_support_level")
default_show_attribute <- append(x = whitelist, values = c("gene_id", "gene_name"))

# query module ------------------------------------------------------------

#' query module ui
#' creates a single query
#' 
#' @param id Module namespace id.
#' @param # TODO add necessary params
#' 
#' @return A shiny tagList.
queryUI <- function(id) {
  ns <- NS(id)
  
  tagList(
    fluidRow(
      useShinyjs(),
      column(
        width = 12,
        orNumericUI(ns("peak_distance"))[c(1, 3)] # 1 = label, 3 = slider
      ),
      column(
        width = 6,
        # direction
        tags$b("Direction"),
        actionLink(
          inputId = ns("direction_help"),
          label = NULL,
          icon = icon("question-circle")
        ),
        selectInput(
          width = "100%",
          inputId = ns("direction"),
          label = NULL,
          choices = c("any_direction", "upstream", "downstream")
        ),
        # internals
        tags$b("Internals"),
        actionLink(
          inputId = ns("internals_help"),
          label = NULL,
          icon = icon("question-circle")
        ),
        selectInput(
          width = "100%",
          inputId = ns("internals"),
          label = NULL,
          choices = c("none", "center", "any")
        ),
        # feature
        tags$b("Feature"),
        actionLink(
          inputId = ns("feature_help"),
          label = NULL,
          icon = icon("question-circle")
        ),
        selectInput(
          width = "100%",
          inputId = ns("feature"),
          label = NULL,
          choices = c("all" = ""),
          multiple = TRUE
        ),
        # filter attribute
        tags$b("Filter attribute"),
        actionLink(
          inputId = ns("filter_attribute_help"),
          label = NULL,
          icon = icon("question-circle")
        ),
        selectInput(
          width = "100%",
          inputId = ns("filter_attribute"),
          label = NULL,
          choices = c("none" = "")
        )
      ),
      column(
        width = 6,
        # strand
        tags$b("Strand"),
        actionLink(
          inputId = ns("strand_help"),
          label = NULL,
          icon = icon("question-circle")
        ),
        selectInput(
          width = "100%",
          inputId = ns("strand"),
          label = NULL,
          choices = c("all" = "", "ignore", "same", "opposite")
        ),
        # feature anchor
        tags$b("Feature anchor"),
        actionLink(
          inputId = ns("feature_anchor_help"),
          label = NULL,
          icon = icon("question-circle")
        ),
        selectInput(
          width = "100%",
          inputId = ns("feature_anchor"),
          label = NULL,
          choices = c("all" = "", "start", "center", "end"),
          multiple = TRUE
        ),
        # show attribute
        tags$b("Show attribute"),
        actionLink(
          inputId = ns("show_attribute_help"),
          label = NULL,
          icon = icon("question-circle")
        ),
        selectInput(
          width = "100%",
          inputId = ns("show_attribute"),
          label = NULL,
          choices = c("none" = ""),
          multiple = TRUE
        ),
        # attribute value
        tags$b("Attribute value"),
        actionLink(
          inputId = ns("attribute_value_help"),
          label = NULL,
          icon = icon("question-circle")
        ),
        selectInput(
          width = "100%",
          inputId = ns("attribute_value"),
          label = NULL,
          choices = c("none" = "")
        )
      )
    )
  )
}

#' query module server side
#' 
#' @param input Shiny's input object.
#' @param output Shiny's output object.
#' @param session Shiny's session object
#' @param featureList All available features from gtf file (3rd column).
#' @param attributeTable Attributes from gtf file (9th column). One column for each attribute.
#' @param feature
#' @param feature.anchor
#' @param distance c(upstream, downstream)
#' @param strand
#' @param direction
#' @param internals
#' @param filter.attributes
#' @param attribute.value
#' @param show.attributes
#' 
#' @return List with query selections within.
query <- function(input, output, session, featureList, attributeTable, feature = NULL, feature.anchor = NULL, distance = c(1000, -1000), strand = NULL, direction = NULL, internals = NULL, filter.attribute = NULL, attribute.value = NULL, show.attributes = NULL) {
  # handle reactive
  featureList_r <- reactive({
    if(is.reactive(featureList)) {
      featureList()
    } else {
      featureList
    }
  })
  attributeTable_r <- reactive({
    if(is.reactive(attributeTable)) {
      res <- attributeTable()
    } else {
      res <- attributeTable
    }
    
    # set show_attribute default selection
    if(isolate(is.null(values$show.attributes))) {
      values$show.attributes <- intersect(names(res), default_show_attribute)
    }
    
    return(res)
  })
  # help popups -------------------------------------------------------------
  # help popups # TODO add help texts
  observeEvent(input$direction_help, {
    showModal(
      modalDialog(
        title = "Direction",
        "Define the peak location relative to the feature’s location, in respect of its orientation. A peak is ‘upstream’ if its center is upstream of a feature anchor position. Accordingly, a peak is ‘downstream’ if its center is downstream of a feature anchor position.",
        size = "m",
        easyClose = TRUE
      )
    )
  })
  observeEvent(input$internals_help, {
    showModal(
      modalDialog(
        title = "Internals",
        HTML("<b>This key represents a modifier with respect to the 'distance' key </b>. This can be helpful to annotate peaks to features with a wide size range, such as genes, which would otherwise be removed due to the distance thresholds. So even if the desired feature anchor is located too far away, a feature can still be included if it is overlapped. "),
        size = "m",
        easyClose = TRUE
      )
    )
  })
  observeEvent(input$feature_help, {
    showModal(
      modalDialog(
        title = "Feature",
        "Peaks will be annotated only to listed features from the 3rd column of the file specified by 'gtf'",
        size = "m",
        easyClose = TRUE
      )
    )
  })
  observeEvent(input$filter_attribute_help, {
    showModal(
      modalDialog(
        title = "Filter attribute",
        "Key filters the attributes found in the 9th column of the GTF file. If a 'filter.attribute' is given, only features that have a 'attribute.value' for this attribute is kept as valid annotations. If this key is set, the key 'attribute.value' is mandatory, too.",
        size = "m",
        easyClose = TRUE
      )
    )
  })
  observeEvent(input$strand_help, {
    showModal(
      modalDialog(
        title = "Strand",
        "The desired strand of the annotated feature relative to the peak. A constraint on strand specificity is only successfully evaluated if strand information is available for the feature and the peak.",
        size = "m",
        easyClose = TRUE
      )
    )
  })
  observeEvent(input$feature_anchor_help, {
    showModal(
      modalDialog(
        title = "Feature anchor",
        "The position(s) from which the distance to the peak center will be calculated. The best annotation is defined as the minimum distance if multiple anchors are defined. Valid distances are less or equal to the distance key value(specified by 'distance').",
        size = "m",
        easyClose = TRUE
      )
    )
  })
  observeEvent(input$show_attribute_help, {
    showModal(
      modalDialog(
        title = "Show attributes",
        "A list of attributes found in the 9th column of the GTF file which should appear in the final output tables. If non existent attributes are specified, annotated peaks will display 'NA' for those attributes.",
        size = "m",
        easyClose = TRUE
      )
    )
  })
  observeEvent(input$attribute_value_help, {
    showModal(
      modalDialog(
        title = "Attribute value",
        "Corresponding attribute value for the 'filter.attribute' found in the 9th column of the GTF file. If a 'filter.attribute' is given, only features that have a 'attribute.value' for this attribute can be valid annotations.",
        size = "m",
        easyClose = TRUE
      )
    )
  })
  
  # module logic ------------------------------------------------------------
  # load orNumeric module
  # use distance as initial slider range if default exceeded
  choices <- c(-10000, 10000)
  if(choices[1] > distance[2] || choices[2] < distance[1]) {
    # even slider
    choices <- rep(max(abs(distance)), 2)
    choices[1] <- -abs(choices[1])
  }
  orModule <- callModule(module = orNumeric, id = "peak_distance", label = "Downstream/ Upstream distance", choices = choices, value = rev(distance))
  
  # set pre set values
  updateSelectizeInput(session = session, inputId = "feature_anchor", selected = feature.anchor)
  updateSelectizeInput(session = session, inputId = "strand", selected = strand)
  updateSelectizeInput(session = session, inputId = "direction", selected = direction)
  updateSelectizeInput(session = session, inputId = "internals", selected = internals)
  
  # pre set values for updated inputs (only used on init/ once)
  values <- reactiveValues(
    feature = feature,
    filter.attribute = filter.attribute,
    attribute.value = attribute.value,
    show.attributes = show.attributes
  )
  
  # update inputs based on gtf file
  # update features
  observe({
    # keep value(s) if all in current set
    featureValue <- isolate(values$feature)
    if(!is.null(featureValue) && all(is.element(featureValue, featureList_r()))) {
      selected <- featureValue
      values$feature <- NULL
    } else {
      selected <- NULL
    }
    
    updateSelectizeInput(session = session, inputId = "feature", choices = featureList_r(), server = TRUE, selected = selected)
  })
  # update filter attribute/ show attribute
  observe({
    filterChoices <- intersect(names(attributeTable_r()), whitelist)
    # keep value(s) if all in current set
    filterValue <- isolate(values$filter.attribute)
    if(!is.null(filterValue) && is.element(filterValue, filterChoices)) {
      filter_selected <- filterValue
      values$filter.attribute <- NULL
    } else {
      filter_selected <- NULL
    }
    
    updateSelectizeInput(session = session, inputId = "filter_attribute", choices = filterChoices, server = TRUE, selected = filter_selected)
    
    showChoices <- names(attributeTable_r())
    # keep value(s) if all in current set
    showValues <- isolate(values$show.attributes)
    if(!is.null(showValues) && all(is.element(showValues, showChoices))) {
      show_selected <- showValues
      values$show.attributes <- NULL
    } else {
      show_selected <- NULL
    }
    
    updateSelectizeInput(session = session, inputId = "show_attribute", choices = showChoices, server = TRUE, selected = show_selected)
  })
  # update/ enable/ disable attribute value based on filter attribute
  observe({
    if(isTruthy(input$filter_attribute)) {
      enable("attribute_value")
      
      # keep value(s) if all in current set
      value <- isolate(values$attribute.value)
      if(!is.null(value) && all(is.element(value, unique(attributeTable_r()[[input$filter_attribute]])))) {
        selected <- value
        if(input$filter_attribute != filter.attribute)
        values$attribute.value <- NULL
      } else {
        selected <- NULL
      }
      
      updateSelectizeInput(session = session, inputId = "attribute_value", choices = unique(attributeTable_r()[[input$filter_attribute]]), server = TRUE, selected = selected)
    } else {
      reset("attribute_value")
      disable("attribute_value")
    }
  })
  
  # internals wrapper
  internals <- reactive({
    if(input$internals == "center") {
      "True"
    } else {
      "False"
    }
  })
  
  # query result
  result <- reactive({
    list(
      feature = if(is.null(input$feature)) "" else input$feature,
      feature.anchor = if(is.null(input$feature_anchor)) "" else input$feature_anchor,
      distance = if(is.null(orModule()$value)) abs(rev(distance)) else abs(rev(orModule()$value)),
      strand = if(is.null(input$strand)) "" else input$strand,
      direction = if(is.null(input$direction)) "" else input$direction,
      internals = internals(), # if(is.null(input$internals)) "" else input$internals,
      filter.attribute = if(is.null(input$filter_attribute)) "" else input$filter_attribute,
      attribute.value = if(is.null(input$attribute_value)) "" else input$attribute_value,
      show.attributes = if(is.null(input$show_attribute)) "" else input$show_attribute
    )
  })
  
  return(result)
}

# app 
# ui ----------------------------------------------------------------------
sidebar_width <- 400
ui <- dashboardPage(
  title = "UROPA",
  dashboardHeader(
    titleWidth = sidebar_width,
    title = tags$span(
      img(src = "uropa_logo.png", height = "50px"),
      tags$b("Universal RObust Peak Annotator")
    ),
    tags$li(
      a(
        href = 'http://www.mpi-hlr.de/en/forschung/service-groups/bioinformatik.html',
        img(src = 'site.logo.jpg', title = "MPI", height = "30px"),
        style = "padding-top:10px; padding-bottom:10px;"
      ),
      class = "dropdown"
    )
  ),
  dashboardSidebar(
    width = sidebar_width,
    useShinyjs(),
    introjsUI(),
    div(
      style = "background-color: #F5ECCE; color: black; padding-bottom: 1px; padding-top: 5px;",
      a(
        "UROPA documentation",
        class = "btn btn-default",
        href = "http://uropa-manual.readthedocs.io/",
        target = "_blank",
        style = "margin-left: 15px; color: #444"
        ),
      actionButton(
        inputId = "help",
        label = "UROPA user guide"
      ),
      actionButton(
        inputId = "demo",
        label = "Load test data"
      )
    ),
    tags$h4("Select relevant GTF file", style = "margin-left: 15px;"),
    div(
      id = "guide_gtf",
      sidebarMenu(
        menuItem(
          text = "Select GTF file",
          div(
            style = "margin-top: -15px; padding-bottom: 10px;",
            selectInput(inputId = "gtf_selector", label = "", choices = gtf_list, width = "100%"),
            actionButton(
              inputId = "load_selected_gtf",
              label = "Load",
              style = "background-color: #F5ECCE; color: #444;"
            )  
          )
        ),
        menuItem(
          text = "Upload custom GTF file",
          div(
            style = "padding-bottom: 10px;",
            fileInput(inputId = "custom_gtf", accept = c(".gtf"), label = NULL, width = "100%"),
            actionButton(
              inputId = "load_custom_gtf",
              label = "Load",
              style = "background-color: #F5ECCE; color: #444; margin-top: -25px;"
            )  
          )
        )#,
        # menuItem(
        #   text = "Provide former UROPA ID",
        #   div(
        #     style = "padding-bottom: 10px;",
        #     textInput(inputId = "uropa_id", label = NULL, placeholder = "Insert ID here", width = "100%"),
        #     actionButton(
        #       inputId = "load_id",
        #       label = "Load",
        #       style = "background-color: #F5ECCE; color: #444;"
        #     )  
        #   )
        # )
      )      
    ),
    tags$hr(),
    div(
      id = "guide_bed",
      fileInput(inputId = "bedfile", label = "Select BED file", accept = c(".bed"), width = "100%")
    ),
    tags$h4("Queries", style = "margin-left: 15px;"),
    div(
      id = "guide_query",
      fluidRow(
        column(
          width = 6,
          actionButton(
            inputId = "add_query",
            label = "Add extra query",
            style = "color: #444; background-color: #F5ECCE;"
          )
        ),
        column(
          width = 6,
          actionButton(
            inputId = "remove_query",
            label = "Remove last query",
            style = "color: #444; background-color: #F5ECCE;"
          )
        )
      )      
    ),
    div(
      id = "guide_prioritize",
      checkboxInput(inputId = "query_prioritized", label = "Prioritized query")      
    ),
    tags$hr(),
    div(
      id = "guide_result",
      fluidRow(
        column(
          width = 6,
          actionButton(
            inputId = "run",
            label = "Run UROPA",
            style = "color: #444; background-color: #F5ECCE;"
          )
         )#,
        # column(
        #   width = 6,
        #   actionButton(
        #     inputId = "download_result",
        #     label = "Download final results",
        #     style = "color: #444; background-color: #F5ECCE;"
        #   )
        # )
      )      
    )
  ),
  dashboardBody(
    # enable page-redirect.js
    tags$head(tags$script(src = "page-redirect.js"),
              tags$style("#shiny-notification-panel {left: 0;}")
              ),
    div(
      style = "text-align: center;",
      img(src = "genomic_location_direction.png")
    ),
    tags$h2("Queries"),
    tabBox(
      # add queries here
      id = "query_container",
      width = NULL
    )
  )
)

# server ------------------------------------------------------------------
server <- function(input, output, session) {
  # make sure right working directory is set
  setwd(wd)
  
  # create unique id + directory
  if(!dir.exists(file.path(result_location))) {
    dir.create(file.path(result_location))
  }
  
  setwd(file.path(result_location))
  id <- dir.create.unique(session$token, usedate = FALSE)
  # cut of tailing '/'
  id <- substr(x = id, start = 1, stop = nchar(id) - 1)
  setwd(wd)
  
  # contains all queries
  queries <- reactiveVal(list())
  
  # how gtf was obtained last
  receiving_method <- reactiveVal(NULL)
  
  ##### parse gtf
  # change obtaining method
  observeEvent(input$load_selected_gtf, {
    req(input$gtf_selector)
    
    receiving_method("select")
    
    # force data load
    selected_gtf()
  })
  
  # parse selected gtf
  selected_gtf <- eventReactive(input$load_selected_gtf, {
    # create progress bar object
    progress <- Progress$new()
    # close progress bar on reactive exit
    on.exit(progress$close())
    
    progress$set(message = "Loading gtf file", value = 0.2)
    gtf_table <- as.data.table(readGFF(file.path(gtf_file_location, input$gtf_selector)))
    
    message(paste0("File ", file.path(gtf_file_location, input$gtf_selector), " loaded."))
    
    progress$set(value = 0.8)
    out <- list(
      featureList = unique(gtf_table[[3]]),
      attributeTable = gtf_table[, -1:-8]
    )
    
    progress$set(value = 1)
    return(out)
  })
  
  # change obtaining method
  observeEvent(input$load_custom_gtf, {
    req(input$custom_gtf)
    
    receiving_method("custom")
    
    # force data load
    custom_gtf()
  })

  # parse custom gtf
  custom_gtf <- eventReactive(input$load_custom_gtf, {
    # create progress bar object
    progress <- Progress$new()
    # close progress bar on reactive exit
    on.exit(progress$close())
    
    progress$set(message = "Loading gtf file", value = 0.2)
    gtf_table <- as.data.table(readGFF(input$custom_gtf$datapath))
    
    message(paste0("File ", input$custom_gtf$name, " loaded."))
    
    progress$set(value = 0.8)
    out <- list(
      featureList = unique(gtf_table[[3]]),
      attributeTable = gtf_table[, -1:-8]
    )
    
    progress$set(value = 1)
    return(out)
  })
  
  # change obtaining method
  observeEvent(input$demo, {
    receiving_method("demo")

    # force data load
    demo_gtf_parsed()
  })

  demo_gtf_parsed <- eventReactive(input$demo, {
    # create progress bar object
    progress <- Progress$new()
    # close progress bar on reactive exit
    on.exit(progress$close())

    progress$set(message = "Loading demo gtf file", value = 0.2)
    gtf_table <- as.data.table(readGFF(file.path(demo_dir, demo_gtf)))

    progress$set(value = 0.8)
    out <- list(
      featureList = unique(gtf_table[[3]]),
      attributeTable = gtf_table[, -1:-8]
    )

    progress$set(value = 1)
    return(out)
  })
  
  # change obtaining method
  # observeEvent(input$load_id, {
  #   req(input$uropa_id)
  #   
  #   receiving_method("id")
  #   
  #   # force data load
  #   id_gtf()
  # })
  
  # parse id gtf
  # id_gtf <- eventReactive(input$load_id, {
    # gtf_table <- as.data.table(readGFF(input$custom_gtf$datapath))
    # 
    # message(paste0("File ", , " loaded."))
    # 
    # list(
    #   featureList = unique(gtf_table[[3]]),
    #   attributeTable = gtf_table[, -1:-8]
    # )
   # })
  
  # return gtf from most recently used method
  gtf <- reactive({
    req(receiving_method())

    if(receiving_method() == "select") {
      return(selected_gtf())
    } else if(receiving_method() == "custom") {
      return(custom_gtf())
    } else if(receiving_method() == "demo") {
      return(demo_gtf_parsed())  
    } # else if(receiving_method() == "id") {
      # return(id_gtf())
    # }
  })
  
  ##### enable/ disable ui
  # upload custom gtf button
  observe({
    if(isTruthy(input$custom_gtf)) {
      enable("load_custom_gtf")
    } else {
      disable("load_custom_gtf")
    }
  })
  
  # load id button
  observe({
    if(isTruthy(input$uropa_id)) {
      enable("load_id")
    } else {
      disable("load_id")
    }
  })
  
  # disable on start
  disable("bedfile")
  disable("add_query")
  disable("remove_query")
  disable("query_prioritized")
  
  # enable middle part sidebar ui if there is a gtf file (as soon as one of the buttons is clicked)
  observeEvent(
    ignoreNULL = FALSE,
    ignoreInit = TRUE,
    eventExpr = {
      input$load_selected_gtf
      input$load_custom_gtf
      input$load_id
    },
    handlerExpr = {
      enable("bedfile")
      enable("add_query")
      enable("remove_query")
      enable("query_prioritized")
    })
  
  # enable bottom part sidebar ui
  observe({
    if(length(queries()) > 0 && isTruthy(input$bedfile) || !is.null(receiving_method()) && receiving_method() == "demo") {
      enable("run")
      # enable("download_result")
    } else {
      disable("run")
      # disable("download_result")
    }
  })

  
  ##### query operations  
  add_event <- reactiveVal()
  
  # add query on init
  observe({
    req(gtf())
    
    if(isolate(length(queries())) == 0 && isolate(receiving_method()) != "demo") {
      add_event(isolate(add_event()) - 1)
    }
  })
  
  # add query on button press
  observe({
    add_event(input$add_query)
  })

  # add query
  observeEvent(add_event(), {
    req(gtf())
    
    # get number of currently active queries
    num_queries <- length(queries()) + 1

    # load new query module (server)
    newQuery <- callModule(module = query, id = paste0("query", num_queries), featureList = reactive(gtf()$featureList), attributeTable = reactive(gtf()$attributeTable))
    
    # add to query list
    queries(append(x = queries(), values = newQuery, after = length(queries())))
    
    # generate and add corresponding ui
    appendTab(
      inputId = "query_container",
      select = TRUE,
      tab = tabPanel(
        title = paste("Query", num_queries),
        queryUI(id = paste0("query", num_queries))
        )
    )
  })
  
  # remove query
  observeEvent(input$remove_query, {
    # get number of currently active queries
    num_queries <- length(queries())
    
    # remove from query list
    queries(queries()[-length(num_queries)])
    
    # remove query ui
    removeTab(
      inputId = "query_container",
      target = paste("Query", num_queries)
    )
  })
  
  # prepare config file
  config <- reactive({
    # get values from all queries
    query_values <- lapply(queries(), function(x) {
      x()
    })
    
    gtf <- switch(receiving_method(),
                  select = input$gtf_selector,
                  custom = input$custom_gtf$name,
                  demo = demo_gtf# ,
                  # id = ""
                  )
    
    bed <- switch(receiving_method(),
                  demo = demo_bed,
                  input$bedfile$name)
    
    config <- list(
      queries = query_values,
      priority = as.character(input$query_prioritized),
      gtf = file.path(wd, result_location, id, gtf),
      bed = file.path(wd, result_location, id, bed)
    )
    
    toJSON(config, pretty = TRUE)
  })
  
  # assemble server url
  url <- reactive({
    protocol <- session$clientData$url_protocol
    ip <- session$clientData$url_hostname
    # shiny_port <- session$clientData$url_port
     path <- session$clientData$url_pathname
    app_name <- gsub("^.*/(.*)", wd, perl = TRUE, replacement = "\\1")
    
    # add ':' to portnumber if necessary (= port defined)
    if (!is.null(port)) {
      port <- paste0(":", port)
    }
    
    return(list(ip = paste0(protocol, "//", ip, port, "/", app_name, "/"),
                return_ip = paste0(protocol, "//", ip, path)
                )
           )
  })

  
  ##### run UROPA
  observeEvent(input$run, {
    disable("run")
    
    # create progress bar object
    progress <- Progress$new()
    # close progress bar on reactive exit
    on.exit(progress$close())
    
    progress$set(message = "Preparing to run UROPA...", value = 0.2)
    
    # change working directory
    setwd(file.path(result_location, id))
    
    progress$set(detail = "Copy bed file", value = 0.35)
    # copy & rename uploaded bed file & gtf to run folder
    switch(receiving_method(),
           demo = file.copy(from = file.path(wd, demo_dir, demo_bed), to = demo_bed),
           file.copy(from = input$bedfile$datapath, to = input$bedfile$name)
    )
    
    progress$set(detail = "Copy gtf file", value = 0.75)
    switch(receiving_method(), 
           select = file.copy(from = file.path(wd, gtf_file_location, input$gtf_selector), to = input$gtf_selector),
           custom = file.copy(from = input$custom_gtf$datapath, to = input$custom_gtf$name),
           demo = file.copy(from = file.path(wd, demo_dir, demo_gtf), to = demo_gtf)#,
           # id = ""
    )
    
    progress$set(detail = "Write config file", value = 0.9)
    # config file name
    config_name <- "config.json"
    
    # write config file
    write(config(), file = config_name)
    
    # create RESULT directory and set as working directory
    dir.create("RESULTS")
    setwd("RESULTS")
    
    message("Starting UROPA...")
    
    progress$set(message = "Starting UROPA...", detail = NULL, value = 1)
    # run script
    uropa_script <- paste0("uropa -i ", file.path(wd, result_location, id, config_name), " -d -s -t ", thread_num, " > stdout.log 2> stderr.err")
    system(uropa_script, wait = FALSE)
    session$sendCustomMessage(type = 'redirectMessage', message = list(id = id, ip = url()$ip, return_ip = url()$return_ip))
    
    # setwd(wd)
    # enable("run")
  })
  
  ##### guide
  observeEvent(input$help, {
    introjs(session, options = list(
      steps = data.frame(
        element = c("#guide_gtf", "#guide_bed", "#guide_query", "#guide_prioritize", "#guide_result"),
        intro = c(
          "<h4>Select relevant GTF file and press Parse.</h4><br/>
            The GTF file acts as annotation database. You can select a predefined file from the list, ask the authors to add your GTF of interest permanently, or upload your custom GTF file. If your custom annotation file is not in the Ensembl GTF format,a conversion can be done by UROPA (see documentation of the commandline version).",
          "Please provide your regions of interest (e.g. enriched regions from a peak-calling). The BED file is a tab-delimited file (Ensembl Bed format) containing the exact genomic locations ,with a minimum of 3 columns (chr/start/stop).",
          "<h4> Customize queries</h4><br/>
            Add or remove queries by using the respective buttons.",
          "<h4>Priority</h4><br/>
            Allows to switch the interpretation of multiple queries from equally weighted to hierarchically weighted (first to last query), meaning that a peak is annotated according to subsequent queries only if no match to the preceding query is found. If ‘False’, all given queries are weighted equally and any feature matching with any of these queries will be reported as a valid annotation. If only one query is provided, the value of ‘priority’ has no influence on the annotation process.",
          "<h4>Run and Download</h4><br/>
            After the queries are set run UROPA here and later download the results."
        )
      )
    ))
  })
  
  # demo run/ load test data
  observeEvent(input$demo, {
    demo_config_parsed <- fromJSON(file.path(demo_dir, demo_config))
    
    # clear former query if any
    old_num_queries <- length(queries())
    if(old_num_queries > 0) {
      for(i in 1:old_num_queries) {
        # remove query ui
        removeTab(
          inputId = "query_container",
          target = paste("Query", i)
        )
      }
      
      # delete server side
      queries(list())
    }

    req(gtf())

    # create query out of config
    lapply(demo_config_parsed$queries, function(x) {
      # get number of currently active queries
      num_queries <- length(queries()) + 1
      
      # generate and add query ui
      appendTab(
        inputId = "query_container",
        select = TRUE,
        tab = tabPanel(
          title = paste("Query", num_queries),
          queryUI(id = paste0("query", num_queries))
        )
      )
      
      # account for all values internals can appear as
      if(!is.null(x$internals) && is.element(x$internals, c("T", "True", "Y", "Yes"))) {
        internals <- "center"
      } else if(!is.null(x$internals) && is.element(x$internals, c("F", "False", "N", "No"))) {
        internals <- "none"
      } else {
        internals <- x$internals
      }
      
      # distance must be a length two vector
      if(length(x$distance) <= 1) {
        distance <- rep(x$distance, 2)
      } else {
        distance <- x$distance
      }
      # negate downstream value so it is below zero on the slider
      distance[2] <- -abs(distance[2])
      
      # load new query module
      newQuery <- callModule(module = query, id = paste0("query", num_queries), featureList = reactive(gtf()$featureList), attributeTable = reactive(gtf()$attributeTable),
                             # set config selection
                             feature = x$feature,
                             feature.anchor = x$feature.anchor,
                             distance =  distance,
                             strand = x$strand,
                             direction = x$direction,
                             internals = internals,
                             filter.attribute = x$filter.attribute,
                             attribute.value = x$attribute.value,
                             show.attributes = if(is.null(x$show.attributes)) "" else x$show.attributes
      )
      
      # add to query list
      queries(append(x = queries(), values = newQuery, after = length(queries())))
    })
    
    # enable query buttons
    enable("add_query")
    enable("remove_query")
    
    # update priority & enable
    # account for all values priority can appear as
    if(!is.null(demo_config_parsed$priority) && is.element(demo_config_parsed$priority, c("T", "True", "Y", "Yes"))) {
      value <- TRUE
    } else {
      value <- FALSE
    }
    
    updateCheckboxInput(session = session, inputId = "query_prioritized", value = value)
    enable("query_prioritized")
    
    # enable run
    enable("run")
  })
}

shinyApp(ui = ui, server = server)