#' @import TrenaProject
#' @import shiny
#' @import shinydashboard
#' @import shinyjs
#' @import later
#' @import yaml
#' @import igvShiny
#' @import DT
#' @import VariantAnnotation
#' @import trenaSGM
#' @importFrom RColorBrewer brewer.pal
#' @import colourpicker
#' @import later
#' @import MotifDb
#' @import ggseqlogo
#' @importFrom GenomicScores gscores
#' @import phastCons7way.UCSC.hg38
#------------------------------------------------------------------------------------------------------------------------
#' @name TrenaViz
#' @rdname TrenaViz
#' @aliases TrenaViz
#------------------------------------------------------------------------------------------------------------------------
tbl.region <- data.frame(chrom="chr19", start=1036002, end=1142642, stringsAsFactors=FALSE)
bsm <- BindingSitesManager()
fimoBuilder <- FimoModelWidget()
genomicRegionString <- "" #with(tbl.regions, sprintf("%s:%d-%d", chrom, start, end))
#------------------------------------------------------------------------------------------------------------------------
state <- new.env(parent=emptyenv())
state$trenaVizRunning <- FALSE
state$models <- list()
state$tbl.chipSeq <- NULL
model.count <- 0 # for creating default model names
MAX.TF.COUNT <- 100 # we display the top max.tf.cout TFs coming back from trena
colors <- brewer.pal(8, "Dark2")
totalColorCount <- length(colors)
state$colorNumber <- 0
#------------------------------------------------------------------------------------------------------------------------
.TrenaViz <- setClass ("TrenaViz",
representation = representation(
projectName="character",
project="TrenaProject",
quiet="logical")
)
#------------------------------------------------------------------------------------------------------------------------
setGeneric('createUI', signature='obj', function(obj) standardGeneric("createUI"))
setGeneric('createServer', signature='obj', function(obj, session, input, output) standardGeneric("createServer"))
setGeneric('createApp', signature='obj', function(obj, port=NA_integer_) standardGeneric("createApp"))
#------------------------------------------------------------------------------------------------------------------------
#' Create an TrenaViz object
#'
#' @description
#' a shiny app
#'
#' @rdname TrenaViz
#'
#' @param projectName A string indicating a TrenaProject subclass
#' @param quiet A logical indicating whether or not the Trena object should print output
#'
#' @return An object of the TrenaViz class
#'
#' @export
#'
TrenaViz <- function(projectName, quiet=TRUE)
{
state$trenaVizRunning <- TRUE
require(projectName, character.only=TRUE)
initialization.command <- sprintf("trenaProject <- %s()", projectName)
eval(parse(text=initialization.command))
setTargetGene(trenaProject, "GATA2")
genome.build <- getGenome(trenaProject)
setGenome(bsm, genome.build)
setTrenaProject(fimoBuilder, trenaProject)
setTargetGene(fimoBuilder, "GATA2")
tbls.regulatoryRegions <- get(load("~/github/TrenaViz/inst/devel/tbls.regulatoryRegions.RData"))
setRegulatoryRegions(fimoBuilder, tbls.regulatoryRegions)
organism <- "Hsapiens"
if(genome.build == "mm10")
organism <- "Mmusculus"
setOrganism(bsm, organism) # getOrganism(trenaProject)
#tbl.region <- data.frame(chrom="chr19", start=1036002, end=1142642, stringsAsFactors=FALSE)
region.list <- getGeneRegion(trenaProject, 20)
tbl.region <- with(region.list, data.frame(chrom=chrom, start=start, end=end, stringsAsFactors=FALSE))
#printf("--- calling sgr(bsm) from TrenaViz ctor")
#setGenomicRegion(bsm, tbl.region)
dataManifest <- list()
base.class.manifest.file <- system.file(package="TrenaProject", "extdata", "genomeAnnotation", "manifest.yaml")
project.manifest.file <- system.file(package=projectName, "extdata", "genomeAnnotation", "manifest.yaml")
if(file.exists(base.class.manifest.file))
dataManifest <- c(dataManifest, yaml.load(readLines(base.class.manifest.file)))
if(file.exists(project.manifest.file))
dataManifest <- c(dataManifest, yaml.load(readLines(project.manifest.file)))
setTargetGene(trenaProject, getSupportedGenes(trenaProject)[1])
state$tbl.enhancers <- getEnhancers(trenaProject)
state$tbl.dhs <- getEncodeDHS(trenaProject)
state$tbl.transcripts <- getTranscriptsTable(trenaProject)
state$dataManifest <- dataManifest
state$chromLocRegion <- getGeneRegion(trenaProject, 20)$chromLocString
obj <- .TrenaViz(projectName=projectName, project=trenaProject, quiet=quiet)
obj
} # TrenaViz ctor
#------------------------------------------------------------------------------------------------------------------------
#' Create the user interface
#'
#' @rdname createUI
#' @aliases createUI
#'
#' @param obj An object of class TrenaViz
#'
#' @export
#'
setMethod('createUI', 'TrenaViz',
function(obj){
ui <- dashboardPage(
dashboardHeader(title=sprintf("trena %s", getTargetGene(obj@project))),
.createSidebar(obj),
dashboardBody(
includeCSS(system.file(package="TrenaViz", "css", "trenaViz.css")),
useShinyjs(),
extendShinyjs(script=system.file(package="TrenaViz", "js", "trenaViz.js")),
extendShinyjs(script=system.file(package="TrenaViz", "js", "bindingSitesManager.js")),
extendShinyjs(script=system.file(package="TrenaViz", "js", "fimoBuilder.js")),
.createBody(obj@project))
) # dashboardPage
return(ui)
})
#------------------------------------------------------------------------------------------------------------------------
#' Create the shiny server
#'
#' @rdname createServer
#' @aliases createServer
#'
#' @param obj An object of class TrenaViz
#' @param session A shiny session
#' @param input A shiny input object
#' @param output A shiny output object
#'
#' @export
#'
setMethod('createServer', 'TrenaViz',
function(obj, session, input, output){
.createTrackFileUploader(session, input, output)
addEventHandlers(bsm, session, input, output)
js$installTrenaVizReturnKeyHandlers()
observeEvent(input$sidebarMenu, {
tabName <- input$sidebarMenu
printf("sidebar menu selected: %s", tabName)
if(tabName == "fimoDatabaseModelBuilderTab"){
printf("--- creating fimoBuilder tab, adding event hanlders, setting genomic region")
displayPage(fimoBuilder)
addEventHandlers(fimoBuilder, session, input, output)
current.region <- state[["chromLocRegion"]]
#print(" creating a fresh fimoBuilder page")
#print("want to call setGenomicRegion(fimoBuilder, ...")
#print(" current.region for fimoBuilder:")
print(current.region) # a chromLocString like this: "chr3:128,480,214-128,487,293"
chromLoc <- trena::parseChromLocString(current.region)
tbl.region <- with(chromLoc, data.frame(chrom=chrom, start=start, end=end, stringsAsFactors=FALSE))
setGenomicRegion(fimoBuilder, tbl.region)
}
})
observeEvent(input$textInput_offListGene_widget_returnKey, ignoreInit=TRUE, {
printf("--- textInput_offListGene_widget_returnKey event received")
newGene <- isolate(input$textInput_offListGene)
if(getGenome(obj@project) == "hg38")
newGene <- toupper(newGene)
legit <- recognizedGene(obj@project, newGene)
if(!legit){
msg <- sprintf("'%s' not found in current datasets.", newGene)
showModal(modalDialog(title="gene nomination error", msg))
}
if(legit){
shinyjs::html(selector=".logo", html=sprintf("trena %s", newGene), add=FALSE)
success <- setTargetGene(obj@project, newGene)
newRegion <- getGeneRegion(obj@project, flankingPercent=20)$chromLocString
printf("--- new region for %s: %s", newGene, newRegion)
showGenomicRegion(session, newRegion)
state$tbl.enhancers <- getEnhancers(obj@project)
state$tbl.dhs <- getEncodeDHS(obj@project)
state$tbl.transcripts <- getTranscriptsTable(obj@project)
}
})
observeEvent(input$setOffListGeneButton, ignoreInit=TRUE, {
newGene <- toupper(isolate(input$offListGene))
legit <- recognizedGene(obj@project, newGene)
if(!legit){
msg <- sprintf("'%s' not found in current datasets.", newGene)
showModal(modalDialog(title="gene nomination error", msg))
}
if(legit){
shinyjs::html(selector=".logo", html=sprintf("trena %s", newGene), add=FALSE)
setTargetGene(obj@project, newGene)
state$tbl.enhancers <- getEnhancers(obj@project)
state$tbl.dhs <- getEncodeDHS(obj@project)
state$tbl.transcripts <- getTranscriptsTable(obj@project)
showGenomicRegion(session, getGeneRegion(obj@project, flankingPercent=20)$chromLocString)
}
})
observeEvent(input$chooseGeneFromList, ignoreInit=TRUE, {
# TODO: consolidate this code with that above, setOffListGeneButton code
newGene <- isolate(input$chooseGeneFromList)
if(nchar(newGene) > 0){
shinyjs::html(selector=".logo", html=sprintf("trena %s", newGene), add=FALSE)
setTargetGene(obj@project, newGene)
showGenomicRegion(session, getGeneRegion(obj@project, flankingPercent=20)$chromLocString)
printf("new targetGene: %s", getTargetGene(obj@project))
state$tbl.enhancers <- getEnhancers(obj@project)
state$tbl.dhs <- getEncodeDHS(obj@project)
state$tbl.transcripts <- getTranscriptsTable(obj@project)
loadAndDisplayRelevantVariants(obj@project, session, newGene)
later(function() {updateSelectInput(session, "chooseGeneFromList", selected=character(0))}, 1)
} # if not empty string
})
output$igvShiny <- renderIgvShiny({
printf("project name: %s", getProjectName(obj@project))
printf("project targetGene: %s", getTargetGene(obj@project))
region.list <- getGeneRegion(obj@project, flankingPercent=20)
chromLocString <- region.list$chromLocString
tbl.region <- with(region.list, data.frame(chrom=chrom, start=start, end=end, stringsAsFactors=FALSE))
printf("renderIgvShiny, chrom loc? %s", chromLocString)
printf("--- calling sgr(bsm) from renderIgvShiny")
setGenomicRegion(bsm, tbl.region)
setGenomicRegion(fimoBuilder, tbl.region)
options <- list(genomeName=getGenome(obj@project),
initialLocus=chromLocString,
displayMode="EXPANDED",
trackHeight=300)
igvShiny(options) # , height=800)
})
output$table = DT::renderDataTable(data.frame(),
width="800px",
class='nowrap display',
selection="single",
extensions="FixedColumns",
options=list(scrollX=TRUE,
scrollY="500px",
dom='t',
paging=FALSE,
autowWdth=FALSE,
fixedColumns=list(leftColumns=1)
))
observeEvent(input$table_rows_selected, {
selectedTableRow <- isolate(input$table_rows_selected)
dispatch.rowClickInModelTable(obj@project, session, input, output, selectedTableRow)
}) # observe row selection event
observeEvent(input$currentGenomicRegion, {
new.region <- isolate(input$currentGenomicRegion)
#printf("new region: %s", new.region)
state[["chromLocRegion"]] <- new.region
chromLoc <- trena::parseChromLocString(new.region)
tbl.region <- with(chromLoc, data.frame(chrom=chrom, start=start, end=end, stringsAsFactors=FALSE))
printf("--- calling sgr(bsm)(fimoBuilder) from TrenaViz:observeEvent, input$currentGenomicRegion")
print(tbl.region)
setGenomicRegion(bsm, tbl.region)
setGenomicRegion(fimoBuilder, tbl.region)
})
setupIgvAndTableToggling(session, input);
setupAddTrack(obj@project, session, input, output)
setupDisplayRegion(obj@project, session, input, output)
setupBuildModel(obj@project, session, input, output)
setupDisplayMotifs(obj@project, session, input, output)
})
#------------------------------------------------------------------------------------------------------------------------
.createBody <- function(project)
{
body <- #fluidRow(
tabItems(
tabItem(tabName="igvAndTable",
fluidRow(
column(width=9, id="igvColumn", igvShinyOutput('igvShiny', height="2000px")),
column(width=3, id="dataTableColumn",
selectInput("modelSelector", NULL, "- no models yet -"),
DTOutput("table"),
br(),
#wellPanel(
h4("TF selection will display:"),
selectInput("selectRowAction", NULL, c("(no action)",
"Motif-matched regulatory regions",
"Calculate Binding Sites",
"ChIP-seq hits"))
) # column
) # fluidRow
), # tabItem 1
.createBuildModelTab(project),
.createFimoDatabaseModelBuilderTab(),
.createVideoTab(),
.createBindingSitesManagerTab()
) # tabItems
return(body)
} # createBody
#------------------------------------------------------------------------------------------------------------------------
.createSidebar <- function(obj)
{
dashboardSidebar(
sidebarMenu(id="sidebarMenu",
menuItem("IGV and Current Models", tabName = "igvAndTable"),
menuItem("Build Footprint Model", tabName = "buildFootprintModels"),
menuItem("Build ATAC-seq Model", tabName = "fimoDatabaseModelBuilderTab"),
menuItem("Introductory video", tabName = "video"),
menuItem("Binding Sites Manager", tabName = "bindingSitesManagerTab")
),
#h5("Choose TF:"),
#selectInput("tfSelector", NULL, c("", "HES7", "LYL1", "IRF5", "SPI1", "CEBPA", "ELK3", "RUNX1")),
conditionalPanel(id="igvTableWidgets",
condition = "input.sidebarMenu == 'igvAndTable'",
actionButton(inputId = "igvHideButton", label = "Toggle IGV"),
actionButton(inputId = "tableHideButton", label = "Toggle table"),
selectInput("chooseGeneFromList", "Choose Gene From List:", c("", getSupportedGenes(obj@project))),
# div(style="display: inline-block;vertical-align:top; width:100px; margin:0px; !important;",
textInput("textInput_offListGene", label="Enter off-list gene"), # , placeholder="enter off-list gene here"),
#div(style="display: inline-block;vertical-align:top; width: 40px; margin-left:0px; margin-top:8px; !important;",
#actionButton(inputId="setOffListGeneButton", label="Set off-list gene"),
selectInput("addTrack", "Add Track:", .additionalTracksOnOffer(obj)),
actionButton(inputId = "addTrackFromFileButton", label="Add Track from File..."),
selectInput("displayGenomicRegion", "Display Genomic Region:",
c("",
"Proximal Promter -2500/+500" = "proximal.promoter.2500.500",
"Full Gene" = "fullGeneRegion",
"Full Enhancers Region" = "fullEnhancerRegion")),
actionButton(inputId="removeUserAddedTracks", label="Remove Added Tracks")
) # conditionalPanel
) # dashboardSidebar
} # .createSidebar
#------------------------------------------------------------------------------------------------------------------------
.additionalTracksOnOffer <- function(obj)
{
trackOfferings <- list("",
"DNase HS (encode, clustered)"="dhs",
"phast7" = "phast7")
dm <- state$dataManifest
for(i in seq_len(length(dm))){
detailed.name <- names(dm)[i]
desc <- dm[[i]]
display.name <- desc$displayName
trackOfferings[[display.name]] <- detailed.name
xyz <- 99
}
genomicRegionNames <- getGenomicRegionsDatasetNames(obj@project)
for(i in seq_len(length(genomicRegionNames))){
trackName <- genomicRegionNames[i]
new.list <- c(trackName)
names(new.list) <- trackName
trackOfferings <- c(trackOfferings, new.list)
} # for i
variantTrackNames <- getVariantDatasetNames(obj@project)
for(i in seq_len(length(variantTrackNames))){
trackName <- variantTrackNames[i]
if(grepl("gwas", trackName, ignore.case=TRUE)){
new.list <- c(trackName)
names(new.list) <- trackName
trackOfferings <- c(trackOfferings, new.list)
} # if 'gwas' in the name
if(grepl(".variants", trackName, ignore.case=TRUE)){
new.list <- c(trackName)
names(new.list) <- trackName
trackOfferings <- c(trackOfferings, new.list)
} # if '.variants' in the name
} # for i
return(trackOfferings)
} # .additionalTracksOnOffer
#------------------------------------------------------------------------------------------------------------------------
.createBuildModelTab <- function(project)
{
footprintDatabases <- getFootprintDatabaseNames(project)
expressionMatrixNames <- getExpressionMatrixNames(project)
tab <- tabItem(tabName="buildFootprintModels",
h4("Build trena regulatory model from DNase footprints in the genomic region currently displayed in IGV, with these constraints:"),
br(),
fluidRow(
column(3, offset=1, checkboxGroupInput("footprintDatabases", "Footprint Databases",
footprintDatabases,
selected=footprintDatabases[1])),
column(4, radioButtons("intersectWithRegions", "Intersect footprints with:",
c("GeneHancer" = "genehancer",
"Encode DHS" = "encodeDHS",
"GeneHancer OR Encode DHS" = "geneHancerOrEncode",
"GeneHancer AND Encode DHS" = "geneHancerAndEncode",
"Use all footprints in region" = "allDNAForFootprints"),
selected="allDNAForFootprints")),
column(3, radioButtons("motifMapping", "Map motifs to TFs via:",
c("MotifDb", "TFClass", "MotifDb + TFClass"),
selected="MotifDb"))
),
fluidRow(
column(6, selectInput("expressionSet", "With this gene expression dataset:",
c("", expressionMatrixNames))),
column(5, textInput("modelNameTextInput", "Model name", width=500))),
fluidRow(column(width=1, offset=4, actionButton("buildModelButton", "Build model"))),
br(),br(),
wellPanel(style="overflow-y:scroll; height:200px", pre(id = "console"))
) # tabItem
return(tab)
} # .createBuildModelTab
#------------------------------------------------------------------------------------------------------------------------
.createVideoTab <- function()
{
file <- system.file(package="TrenaViz", "extdata", "video", "videoTutorial.html")
tab <- tabItem(tabName="video",
h4("Using TrenaViz: a video tutorial"),
includeHTML(file)
)
return(tab)
} # .createVideoTab
#------------------------------------------------------------------------------------------------------------------------
# .createMotifTab <- function()
# {
# xyz <- ".createMotifTab"
# tab <- tabItem(tabName="motifTab",
# h4("Select a Motif"),
# actionButton(inputId = "displayMotifButton", label = "Display Motif"),
# plotOutput("motifPlotRenderingPanel", height=800)
# )
# return(tab)
#
# } # .createMotifTab
#------------------------------------------------------------------------------------------------------------------------
.createBindingSitesManagerTab <- function()
{
tabItem(tabName="bindingSitesManagerTab",
fluidPage(id="bindingSitesManagerPage",
h3(id="bindingSitesManager_title", "Explore Binding Sites"),
h4(id="bindingSitesManager_currentTF", sprintf("TF: %s", "none yet specified")),
h4(id="bindingSitesManager_currentGenomicRegion", genomicRegionString),
textInput("textInput_exploreAnotherTF", label="Specify a new TF:"),
fluidRow(id="bindingSitesManagerPageContent")))
} # .createExperimentalTab
#------------------------------------------------------------------------------------------------------------------------
.createFimoDatabaseModelBuilderTab <- function()
{
printf("creating fimoDatabaseModelBuilderTab")
tabItem(tabName="fimoDatabaseModelBuilderTab",
fluidPage(id="FimoModelWidgetPage",
h3(id="fimoDatabaseBuild_title", "Build Gene Regulatory Model Using Fimo Database"),
fluidRow(id="FimoDatabaseModelBuilderPageContent")))
} # .createFimoDatabaseModelBuilderTab
#------------------------------------------------------------------------------------------------------------------------
#' Create a runnable shiny app
#'
#' @rdname createApp
#' @aliases createApp
#'
#' @param obj An object of class TrenaViz
#' @param port An integer (e.g., 3838, 60041) NA_integer_ by default
#'
#' @export
#'
setMethod('createApp', 'TrenaViz',
function(obj, port=NA_integer_){
server <- function(session, input, output){
x <- createServer(obj, session, input, output)
}
if(Sys.info()[["nodename"]] == "riptide.local"){
shinyOptions <- list(host="0.0.0.0", port=port, launch.browser=TRUE)
} else {
shinyOptions=list(launch.browser=FALSE, host='0.0.0.0', port=port)
}
app <- shinyApp(createUI(obj), server, options=shinyOptions)
return(app)
})
#------------------------------------------------------------------------------------------------------------------------
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.