R/helpers.R
In PriceLab/cytofViz: CytofViz
setupIgvAndTableToggling <- function(session, input)
{
observeEvent(input$currentGenomicRegion, {
newValue <- input$currentGenomicRegion
state$chromLocRegion <- newValue
})
observeEvent(input$igvHideButton, {
if(input$igvHideButton %% 2 == 1){
printf(" --- hiding igv, widening dataTable")
shinyjs::hide(id = "igvColumn")
shinyjs::toggleClass("dataTableColumn", "col-sm-3")
shinyjs::toggleClass("dataTableColumn", "col-sm-12")
} else {
printf(" --- showing igv, narrowing dataTable")
shinyjs::toggleClass("dataTableColumn", "col-sm-12")
shinyjs::toggleClass("dataTableColumn", "col-sm-3")
shinyjs::show(id = "igvColumn")
}
printf("--- calling redrawIgvWidget after igv toggle button")
redrawIgvWidget(session)
redrawModelDataTable()
})
observeEvent(input$tableHideButton, {
if(input$tableHideButton %% 2 == 1){
shinyjs::hide(id = "modelSelectorColumn")
shinyjs::hide(id = "dataTableColumn")
shinyjs::toggleClass("igvColumn", "col-sm-9")
shinyjs::toggleClass("igvColumn", "col-sm-12")
} else {
shinyjs::toggleClass("igvColumn", "col-sm-12")
shinyjs::toggleClass("igvColumn", "col-sm-9")
shinyjs::hide(id = "modelSelectorColumn")
shinyjs::hide(id = "dataTableColumn")
shinyjs::show(id = "dataTableColumn")
shinyjs::show(id = "modelSelectorColumn")
}
printf("--- calling redrawIgvWidget after table toggle button")
redrawIgvWidget(session)
redrawModelDataTable()
})
} # setupIgvAndTableToggling
#------------------------------------------------------------------------------------------------------------------------
redrawModelDataTable <- function()
{
# columns.adjust not actually needed, except perhaps if the column names have changed
# jQuery.string <- "$('#table table.dataTable[id]').DataTable().columns.adjust().draw();"
# it is not at all clear where and how [id] is resolved by the js interpreter in the browser
jQuery.string <- "$('#table table.dataTable[id]').DataTable().draw();"
shinyjs::runjs(jQuery.string)
} # redrawModelDataTable
#------------------------------------------------------------------------------------------------------------------------
mapToChromLoc <- function(regionName)
{
roi <- getTargetGene(trenaProject) # a safe fallback
if(regionName == "traditionalPromoter"){
tbl.transcripts <- getTranscriptsTable(trenaProject)
chrom <- subset(tbl.transcripts, moleculetype=="gene")$chr
strand <- subset(tbl.transcripts, moleculetype=="gene")$strand
gene.start <- subset(tbl.transcripts, moleculetype=="gene")$start
gene.end <- subset(tbl.transcripts, moleculetype=="gene")$endpos
upstream <- 5000
downstream <- 5000
if(strand == "+"){
tss <- gene.start
start <- tss - upstream
end <- tss + downstream
}
if(strand == "-"){
tss <- gene.end
start <- tss - downstream
end <- tss + upstream
}
roi <- sprintf("%s:%d-%d", chrom, start, end)
}
if(regionName == "enhancersRegion"){
chrom <- state$tbl.enhancers$chrom[1]
start <- min(state$tbl.enhancers$start) - 10000
end <- max(state$tbl.enhancers$end) + 10000
roi <- sprintf("%s:%d-%d", chrom, start, end)
}
return(roi)
} # mapToChromLoc
#------------------------------------------------------------------------------------------------------------------------
buildFootprintModel <- function(upstream, downstream)
{
tbl.gene <- subset(getTranscriptsTable(trenaProject), moleculetype=="gene")[1,]
tss <- tbl.gene$start
min.loc <- tss - upstream
max.loc <- tss + downstream
if(tbl.gene$strand == "-"){
tss <- tbl.gene$endpos
min.loc <- tss - downstream
max.loc <- tss + upstream
}
chrom <-tbl.gene$chr
tbl.regions <- data.frame(chrom=chrom, start=min.loc, end=max.loc, stringsAsFactors=FALSE)
mtx <- loadExpressionData(trenaProject, "FilteredLengthScaledTPM8282018-vsn")
build.spec <- list(title=sprintf("%s model %d", getTargetGene(trenaProject), 1),
type="footprint.database",
regions=tbl.regions,
geneSymbol=getTargetGene(trenaProject),
tss=tss,
matrix=mtx,
db.host="khaleesi.systemsbiology.net",
databases=list("brain_hint_20"),
motifDiscovery="builtinFimo",
tfPool=allKnownTFs(identifierType="geneSymbol"),
tfMapping="MotifDB",
tfPrefilterCorrelation=0.1,
annotationDbFile=dbfile(org.Hs.eg.db),
orderModelByColumn="pearsonCoeff",
solverNames=c("lasso", "lassopv", "pearson", "randomForest", "ridge", "spearman"))
#------------------------------------------------------------
# use the above build.spec: a small region, high correlation
# required, MotifDb for motif/tf lookup
#------------------------------------------------------------
fpBuilder <- FootprintDatabaseModelBuilder("hg38", getTargetGene(trenaProject), build.spec, quiet=TRUE)
x <- build(fpBuilder)
xyz <- "back from build"
} # buildFootprintModel
#------------------------------------------------------------------------------------------------------------------------
setupAddTrack <- function(trenaProject, session, input, output)
{
observeEvent(input$addTrack, {
newTrackName <- input$addTrack
if(newTrackName == "") return()
printf(" addTrack event: %s", newTrackName);
displayTrack(trenaProject, session, newTrackName)
later(function() {updateSelectInput(session, "addTrack", selected=character(0))}, 1)
})
} # setupAddTrack
#------------------------------------------------------------------------------------------------------------------------
displayTrack <- function(trenaProject, session, trackName)
{
printf("--- displayTrack('%s')", trackName)
if(grepl(".variants", trackName, ignore.case=TRUE))
displayBedTrack(trenaProject, session, trackName)
if(grepl("gwas", trackName, ignore.case=TRUE))
displayBedTrack(trenaProject, session, trackName)
if(trackName == "enhancers")
displayEnhancersTrack(trenaProject, session)
if(trackName == "dhs")
displayEncodeDhsTrack(trenaProject, session)
} # displayTrack
#------------------------------------------------------------------------------------------------------------------------
displayEnhancersTrack <- function(trenaProject, session)
{
tbl.enhancers <- getEnhancers(trenaProject)
tbl.tmp <- tbl.enhancers[, c("chrom", "start", "end", "combinedScore")]
loadBedGraphTrack(session, "GeneHancer", tbl.tmp, color="black", trackHeight=25, autoscale=FALSE, min=0, max=20)
} # displayEnhancersTrack
#------------------------------------------------------------------------------------------------------------------------
displayEncodeDhsTrack <- function(trenaProject, session)
{
tbl.dhs <- getEncodeDHS(trenaProject)
tbl.tmp <- tbl.dhs[, c("chrom", "chromStart", "chromEnd", "score")]
colnames(tbl.tmp) <- c("chrom", "start", "end", "score")
loadBedGraphTrack(session, "DHS", tbl.tmp, color="black", trackHeight=25, autoscale=TRUE)
} # displayEncodeDhsTrack
#------------------------------------------------------------------------------------------------------------------------
displayGWASTrack <- function(trenaProject, session, trackName)
{
variantDatasetNames <- getVariantDatasetNames(trenaProject)
printf("want to see trackName (%s) among variantDatasetNames", trackName)
print(paste(variantDatasetNames, collapse=", "))
if(trackName %in% variantDatasetNames){
printf(" --- found %s to display", trackName)
printf(" want to restrict variant table to this region: %s", state$chromLocRegion)
loc <- parseChromLocString(state$chromLocRegion)
tbl.variant <- getVariantDataset(trenaProject, trackName)
if(trackName == "GWAS.snps"){
tbl.variant <- tbl.variant[, c("chrom", "start", "end", "pScore")]
colnames(tbl.variant) <- c("chrom", "start", "end", "value")
}
tbl.variant <- subset(tbl.variant, chrom==loc$chrom & start >= loc$start & end <= loc$end)
printf("%d regions in %s", nrow(tbl.variant), trackName)
showNotification(sprintf("%s: %d genomic features", trackName, nrow(tbl.variant)))
if(nrow(tbl.variant) > 0)
loadBedGraphTrack(session, trackName, tbl.variant, color="red", trackHeight=25, autoscale=TRUE) # , min=0, max=10)
} # trackName found in variant data sets
} # displayGWASTrack
#------------------------------------------------------------------------------------------------------------------------
displayBedTrack <- function(trenaProject, session, trackName)
{
variantDatasetNames <- getVariantDatasetNames(trenaProject)
printf("want to see trackName (%s) among variantDatasetNames", trackName)
print(paste(variantDatasetNames, collapse=", "))
if(trackName %in% variantDatasetNames){
printf(" --- found %s to display", trackName)
printf(" want to restrict variant table to this region: %s", state$chromLocRegion)
loc <- parseChromLocString(state$chromLocRegion)
tbl.variant <- getVariantDataset(trenaProject, trackName)
tbl.variant <- subset(tbl.variant, chrom==loc$chrom & start >= loc$start & end <= loc$end)
printf("%d regions in %s", nrow(tbl.variant), trackName)
showNotification(sprintf("%s: %d genomic features", trackName, nrow(tbl.variant)))
if(nrow(tbl.variant) > 0)
loadBedTrack(session, trackName, tbl.variant, color="red", trackHeight=25)
} # trackName found in variant data sets
} # displayBedTrack
#------------------------------------------------------------------------------------------------------------------------
setupDisplayRegion <- function(trenaProject, session, input, output)
{
observeEvent(input$displayGenomicRegion, {
requestedRegion <- input$displayGenomicRegion
if(requestedRegion == "") return()
printf(" displayRegion: %s", requestedRegion)
margin <- 5000
loc.string <-switch(requestedRegion,
fullEnhancerRegion = {getGeneEnhancersRegion(trenaProject, 10)},
fullGeneRegion = {getGeneRegion(trenaProject, 20)})
showGenomicRegion(session, loc.string);
later(function() {updateSelectInput(session, "displayGenomicRegion", selected=character(0))}, 1)
})
observeEvent(input$removeUserAddedTracks, {
removeUserAddedTracks(session)
})
} # setupDisplayRegion
#------------------------------------------------------------------------------------------------------------------------
setupBuildModel <- function(trenaProject, session, input, output)
{
observeEvent(input$modelSelector, ignoreInit=TRUE, {
modelName <- isolate(input$modelSelector)
printf("--- new model selected: %s", modelName)
new.table <- state$models[[modelName]]$model
displayModel(session, input, output, new.table, modelName)
})
observe({
x <- input$sidebarCollapsed;
redrawIgvWidget(session)
})
observe({
currentName <- input$modelNameTextInput
expressionMatrixName <- input$expressionSet
allInputsSpecified <- nchar(currentName) >= 1 & nchar(expressionMatrixName) > 2
if(allInputsSpecified)
shinyjs::enable("buildModelButton")
else
shinyjs::disable("buildModelButton")
})
observeEvent(input$buildModelButton, {
getGenomicRegion(session)
state$tbl.chipSeq <- NULL # this will force a fresh database query after model is built
shinyjs::html(id="console", html="", add=FALSE) # clear the console
tryCatch({
withCallingHandlers({buildModel(trenaProject, session, input, output);
model.count <- length(state$models)
new.model.name <- names(state$models)[model.count]
new.table <- state$models[[model.count]]$model
displayModel(session, input, output, new.table, new.model.name)
updateTabItems(session, "sidebarMenu", select="igvAndTable")
},
message=function(m){
shinyjs::html(id="console", html=m$message, add=TRUE)
})
}, error=function(e){
msg <- e$message
print(msg)
showModal(modalDialog(title="trena model building error", msg))
}) # tryCatch
}) # observe buildModelButton
} # setupBuildModel
#------------------------------------------------------------------------------------------------------------------------
buildModel <- function(trenaProject, session, input, output)
{
model.name <- sprintf("trena.model.%s", input$modelNameTextInput)
message(sprintf("about to build '%s'", model.name))
footprint.database.names <- input$footprintDatabases
tracks.to.intersect.with <- input$intersectWithRegions
motifMapping <- isolate(input$motifMapping)
if(tolower(motifMapping) == "motifdb + tfclass")
motifMapping <- c("MotifDb", "TFClass")
expressionMatrixName <- input$expressionSet
full.roi <- state$chromLocRegion
chrom.loc <- trena::parseChromLocString(full.roi)
message(sprintf(" fpdb: %s", paste(footprint.database.names, collapse=", ")))
message(sprintf(" roi: %s", full.roi))
message(sprintf(" mtx: %s", expressionMatrixName))
message(printf(" intersect with: %s", paste(tracks.to.intersect.with, collapse=",")))
tbl.gene <- subset(state$tbl.transcripts, moleculetype=="gene")[1,]
strand <- tbl.gene$strand
tss <- tbl.gene$start
if(strand == "-")
tss <- tbl.gene$endpos
run.trenaSGM(trenaProject,
model.name,
chrom.loc$chrom, chrom.loc$start, chrom.loc$end,
tss,
expressionMatrixName,
tracks.to.intersect.with,
footprint.database.names,
motifMapping)
} # buildModel
#------------------------------------------------------------------------------------------------------------------------
run.trenaSGM <- function(trenaProject,
model.name,
chromosome, start.loc, end.loc,
tss,
expression.matrix.name,
tracks.to.intersect.with,
footprint.database.names,
motifMapping)
{
message(sprintf("--- entering run.trenaSGM"))
# no search for overlaps just yet: ignore "tracks.to.intersect.with"
#browser()
tbl.regions <- buildRegionsTable(tracks.to.intersect.with, chromosome, start.loc, end.loc,
state$tbl.enhancers, state$tbl.dhs)
#tbl.regions <- data.frame(chrom=chromosome, start=start.loc, end=end.loc, stringsAsFactors=FALSE)
mtx <- getExpressionMatrix(trenaProject, expression.matrix.name)
geneSymbol <- getTargetGene(trenaProject)
for(r in seq_len(nrow(tbl.regions))){
message(sprintf("tbl.regions, width: %d", with(tbl.regions[r,], end - start)))
}
build.spec <- list(title=model.name,
type="footprint.database",
regions=tbl.regions,
geneSymbol=getTargetGene(trenaProject),
tss=tss,
matrix=mtx,
db.host="khaleesi.systemsbiology.net",
databases=footprint.database.names,
motifDiscovery="builtinFimo",
tfPool=allKnownTFs(identifierType="geneSymbol"),
tfMapping=motifMapping,
tfPrefilterCorrelation=0.2,
annotationDbFile=dbfile(org.Hs.eg.db),
orderModelByColumn="pearsonCoeff",
solverNames=c("lasso", "lassopv", "pearson", "randomForest", "ridge", "spearman"))
# save(build.spec, file=sprintf("%s.buildSpec.RData", model.name))
#------------------------------------------------------------
# use the above build.spec: a small region, high correlation
# required, MotifDb for motif/tf lookup
#------------------------------------------------------------
fpBuilder <- FootprintDatabaseModelBuilder("hg38", getTargetGene(trenaProject), build.spec, quiet=FALSE)
x <- build(fpBuilder)
message(sprintf("back from build, top 10 tfs:"))
message(head(x$model, n=10))
#save(x, file=sprintf("%s.results.RData", model.name))
state$models[[model.name]] <- x
} # run.trenaSGM
#------------------------------------------------------------------------------------------------------------------------
buildRegionsTable <- function(tracks.to.intersect.with, chromosome, start.loc, end.loc, tbl.enhancers, tbl.dhs)
{
if(tracks.to.intersect.with == "allDNAForFootprints")
return(data.frame(chrom=chromosome, start=start.loc, end=end.loc, stringsAsFactors=FALSE))
gr.region <- GRanges(seqnames=chromosome, IRanges(start.loc, end.loc))
gr.enhancers <- GRanges(tbl.enhancers)
gr.dhs <- GRanges(tbl.dhs)
# strip off metadata so that the regions can be combined
mcols(gr.region) <- NULL
mcols(gr.enhancers) <- NULL
mcols(gr.dhs) <- NULL
gr.enhancers.or.dhs <- c(gr.enhancers, gr.dhs)
gr.enhancers.and.dhs <- GenomicRanges::intersect(gr.enhancers, gr.dhs)
tbl.out <- switch(tracks.to.intersect.with,
genehancer = {
tbl.ov <- as.data.frame(findOverlaps(gr.enhancers, gr.region, type="any"))
indices <- unique(tbl.ov[,1])
as.data.frame(gr.enhancers[indices])
},
encodeDHS = {
tbl.ov <- as.data.frame(findOverlaps(gr.dhs, gr.region, type="any"))
indices <- unique(tbl.ov[,1])
as.data.frame(gr.dhs[indices])
},
geneHancerOrEncode = {
tbl.ov <- as.data.frame(findOverlaps(gr.enhancers.or.dhs, gr.region, type="any"))
indices <- unique(tbl.ov[,1])
as.data.frame(gr.enhancers.or.dhs[indices], row.names=NULL)
},
geneHancerAndEncode = {
tbl.ov <- as.data.frame(findOverlaps(gr.enhancers.and.dhs, gr.region, type="any"))
indices <- unique(tbl.ov[,1])
as.data.frame(gr.enhancers.and.dhs[indices], row.names=NULL)
})
tbl.out <- tbl.out[, 1:3]
colnames(tbl.out) <- c("chrom", "start", "end")
tbl.out$chrom <- as.character(tbl.out$chrom)
tbl.out$start <- as.numeric(tbl.out$start)
tbl.out$end <- as.numeric(tbl.out$end)
return(tbl.out)
} # buildRegionsTable
#------------------------------------------------------------------------------------------------------------------------
test_buildRegionsTable <- function()
{
library(RUnit)
variables.loaded <- load("buildRegionsTable.sampleData.RData")
stopifnot(all(c("chromosome", "start.loc", "end.loc", "tbl.dhs", "tbl.enhancers") %in% variables.loaded))
intersection.options <- c("genehancer", "encodeDHS", "geneHancerOrEncode",
"geneHancerAndEncode", "allDNAForFootprints")
tbl.regions <- buildRegionsTable("allDNAForFootprints", chromosome, start.loc, end.loc, tbl.enhancers, tbl.dhs)
checkEquals(colnames(tbl.regions), c("chrom", "start", "end"))
checkEquals(unlist(lapply(tbl.regions, class), use.names=FALSE), c("character", "numeric", "numeric"))
checkEquals(dim(tbl.regions), c(1, 3))
tbl.regions <- buildRegionsTable("genehancer", chromosome, start.loc, end.loc, tbl.enhancers, tbl.dhs)
checkEquals(colnames(tbl.regions), c("chrom", "start", "end"))
checkEquals(unlist(lapply(tbl.regions, class), use.names=FALSE), c("character", "numeric", "numeric"))
checkEquals(dim(tbl.regions), c(32, 3))
tbl.regions <- buildRegionsTable("encodeDHS", chromosome, start.loc, end.loc, tbl.enhancers, tbl.dhs)
checkEquals(colnames(tbl.regions), c("chrom", "start", "end"))
checkEquals(unlist(lapply(tbl.regions, class), use.names=FALSE), c("character", "numeric", "numeric"))
checkEquals(dim(tbl.regions), c(2541, 3))
tbl.regions <- buildRegionsTable("geneHancerOrEncode", chromosome, start.loc, end.loc, tbl.enhancers, tbl.dhs)
checkEquals(colnames(tbl.regions), c("chrom", "start", "end"))
checkEquals(unlist(lapply(tbl.regions, class), use.names=FALSE), c("character", "numeric", "numeric"))
checkEquals(dim(tbl.regions), c(2573, 3))
tbl.regions <- buildRegionsTable("geneHancerAndEncode", chromosome, start.loc, end.loc, tbl.enhancers, tbl.dhs)
checkEquals(colnames(tbl.regions), c("chrom", "start", "end"))
checkEquals(unlist(lapply(tbl.regions, class), use.names=FALSE), c("character", "numeric", "numeric"))
checkEquals(dim(tbl.regions), c(341, 3))
} # test_buildRegionsTable
#------------------------------------------------------------------------------------------------------------------------
# beautify the data.frame, display it in the UI DataTable, update the modelSelector pulldown
displayModel <- function(session, input, output, tbl.model, new.model.name)
{
printf("--- entering displayModel: %s", new.model.name)
print(dim(tbl.model))
tf.names <- tbl.model$gene
tbl.model <- tbl.model[, -1]
if("lassoPValue" %in% colnames(tbl.model))
tbl.model <- roundNumericColumns(tbl.model, 4, "lassoPValue")
rownames(tbl.model) <- tf.names
max.model.rows <- MAX.TF.COUNT
if(nrow(tbl.model) > max.model.rows)
tbl.model <- tbl.model[1:max.model.rows,]
output$table = DT::renderDataTable(tbl.model,
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)
))
updateSelectInput(session, "modelSelector",
choices=names(state$models),
selected=new.model.name)
} # displayModel
#------------------------------------------------------------------------------------------------------------------------
dispatch.rowClickInModelTable <- function(trenaProject, session, input, output, selectedTableRow)
{
#current.model.name <- isolate(input$modelSelector)
#if(current.model.name %in% ls(state$models)){
# printf("tf: %s", tf.name)
current.model.name <- isolate(input$modelSelector)
tf.names <- state$models[[current.model.name]]$model$gene
if(length(tf.names) > MAX.TF.COUNT) tf.names <- tf.names[1:MAX.TF.COUNT]
tf.name <- tf.names[selectedTableRow]
action.name <- isolate(input$selectRowAction)
expression.matrix.name <- isolate(input$expressionSet)
#printf("%s of model %s, expression.set %s: %s", tf.name, current.model.name, expression.matrix.name, action.name)
# browser()
xyz <- "botton of dispatch.rowClick"
if(action.name == "Footprints"){
tbl.fp <- state$models[[current.model.name]]$regulatoryRegions
tbl.fp.tf <- subset(tbl.fp, geneSymbol==tf.name)
dups <- which(duplicated(tbl.fp.tf$loc))
if(length(dups) > 0)
tbl.fp.tf <- tbl.fp.tf[-dups,]
tbl.tmp <- tbl.fp.tf[ c("chrom", "fp_start", "fp_end", "shortMotif")]
colnames(tbl.tmp) <- c("chrom", "start", "end", "name")
state$colorNumber <- (state$colorNumber %% totalColorCount) + 1
next.color <- colors[state$colorNumber]
loadBedTrack(session, sprintf("FP-%s", tf.name), tbl.tmp, color=next.color, trackHeight=25)
} # if footprints
if(action.name == "ChIP-seq hits"){
full.roi <- state$chromLocRegion
chrom.loc <- trena::parseChromLocString(full.roi)
if(is.null(state$tbl.chipSeq)){
showNotification("retrieving ChIP-seq data from database (100)...", duration=100, closeButton=TRUE)
tbl.chipSeq <- with(chrom.loc, getChipSeq(trenaProject, chrom, start, end, tf.names))
#save(tbl.chipSeq, file="tbl.chipSeq.RData")
state$tbl.chipSeq <- tbl.chipSeq
hit.count <- nrow(state$tbl.chipSeq)
printf("chipSeq hit.count: %d", hit.count)
showNotification(sprintf("ChIP-seq hits across all TFs in this model: %d", hit.count))
}
tbl.hits <- subset(state$tbl.chipSeq, tf == tf.name)
showNotification(sprintf("ChIP-seq hits for %s: %d", tf.name, nrow(tbl.hits)), type="message")
if(nrow(tbl.hits) > 0){
tbl.tmp <- tbl.hits[, c("chrom", "start", "endpos", "name")]
colnames(tbl.tmp) <- c("chrom", "start", "end", "name")
state$colorNumber <- (state$colorNumber %% totalColorCount) + 1
next.color <- colors[state$colorNumber]
loadBedTrack(session, sprintf("Cs-%s", tf.name), tbl.tmp, color=next.color, trackHeight=25)
}
} # ChIP-seq hits
} # dispatch.rowClickInModelTable
#------------------------------------------------------------------------------------------------------------------------
display.chipseq.track <- function(session, input, output, tf)
{
} # display.chipseq.track
#------------------------------------------------------------------------------------------------------------------------
display.footprint.track <- function(session, input, output, tf)
{
model.name <- isolate(input$modelSelector)
} # display.footprint.track
#------------------------------------------------------------------------------------------------------------------------
loadAndDisplayRelevantVariants <- function(trenaProject, session, newGene)
{
variant.filenames <- getVariantDatasetNames(trenaProject)
short.names <- names(variant.filenames)
file.paths <- unlist(variant.filenames, use.names=FALSE)
vcf.file.indices <- grep(".vcf", short.names, ignore.case=TRUE)
thisGene.indices <- grep(newGene, short.names, ignore.case=TRUE)
final.indices <- intersect(vcf.file.indices, thisGene.indices)
if(length(final.indices) == 0)
return()
current.gene.vcf.files <- file.paths[final.indices]
for(i in seq_len(length(current.gene.vcf.files))){
vcfFile <- current.gene.vcf.files[i]
vcfData <- readVcf(vcfFile)
loadVcfTrack(session, "vcf", vcfData)
}
} # loadAndDisplayRelevantVariants
#------------------------------------------------------------------------------------------------------------------------
PriceLab/cytofViz documentation built on May 15, 2019, 12:57 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
setupIgvAndTableToggling <- function(session, input)
{
observeEvent(input$currentGenomicRegion, {
newValue <- input$currentGenomicRegion
state$chromLocRegion <- newValue
})
observeEvent(input$igvHideButton, {
if(input$igvHideButton %% 2 == 1){
printf(" --- hiding igv, widening dataTable")
shinyjs::hide(id = "igvColumn")
shinyjs::toggleClass("dataTableColumn", "col-sm-3")
shinyjs::toggleClass("dataTableColumn", "col-sm-12")
} else {
printf(" --- showing igv, narrowing dataTable")
shinyjs::toggleClass("dataTableColumn", "col-sm-12")
shinyjs::toggleClass("dataTableColumn", "col-sm-3")
shinyjs::show(id = "igvColumn")
}
printf("--- calling redrawIgvWidget after igv toggle button")
redrawIgvWidget(session)
redrawModelDataTable()
})
observeEvent(input$tableHideButton, {
if(input$tableHideButton %% 2 == 1){
shinyjs::hide(id = "modelSelectorColumn")
shinyjs::hide(id = "dataTableColumn")
shinyjs::toggleClass("igvColumn", "col-sm-9")
shinyjs::toggleClass("igvColumn", "col-sm-12")
} else {
shinyjs::toggleClass("igvColumn", "col-sm-12")
shinyjs::toggleClass("igvColumn", "col-sm-9")
shinyjs::hide(id = "modelSelectorColumn")
shinyjs::hide(id = "dataTableColumn")
shinyjs::show(id = "dataTableColumn")
shinyjs::show(id = "modelSelectorColumn")
}
printf("--- calling redrawIgvWidget after table toggle button")
redrawIgvWidget(session)
redrawModelDataTable()
})
} # setupIgvAndTableToggling
#------------------------------------------------------------------------------------------------------------------------
redrawModelDataTable <- function()
{
# columns.adjust not actually needed, except perhaps if the column names have changed
# jQuery.string <- "$('#table table.dataTable[id]').DataTable().columns.adjust().draw();"
# it is not at all clear where and how [id] is resolved by the js interpreter in the browser
jQuery.string <- "$('#table table.dataTable[id]').DataTable().draw();"
shinyjs::runjs(jQuery.string)
} # redrawModelDataTable
#------------------------------------------------------------------------------------------------------------------------
mapToChromLoc <- function(regionName)
{
roi <- getTargetGene(trenaProject) # a safe fallback
if(regionName == "traditionalPromoter"){
tbl.transcripts <- getTranscriptsTable(trenaProject)
chrom <- subset(tbl.transcripts, moleculetype=="gene")$chr
strand <- subset(tbl.transcripts, moleculetype=="gene")$strand
gene.start <- subset(tbl.transcripts, moleculetype=="gene")$start
gene.end <- subset(tbl.transcripts, moleculetype=="gene")$endpos
upstream <- 5000
downstream <- 5000
if(strand == "+"){
tss <- gene.start
start <- tss - upstream
end <- tss + downstream
}
if(strand == "-"){
tss <- gene.end
start <- tss - downstream
end <- tss + upstream
}
roi <- sprintf("%s:%d-%d", chrom, start, end)
}
if(regionName == "enhancersRegion"){
chrom <- state$tbl.enhancers$chrom[1]
start <- min(state$tbl.enhancers$start) - 10000
end <- max(state$tbl.enhancers$end) + 10000
roi <- sprintf("%s:%d-%d", chrom, start, end)
}
return(roi)
} # mapToChromLoc
#------------------------------------------------------------------------------------------------------------------------
buildFootprintModel <- function(upstream, downstream)
{
tbl.gene <- subset(getTranscriptsTable(trenaProject), moleculetype=="gene")[1,]
tss <- tbl.gene$start
min.loc <- tss - upstream
max.loc <- tss + downstream
if(tbl.gene$strand == "-"){
tss <- tbl.gene$endpos
min.loc <- tss - downstream
max.loc <- tss + upstream
}
chrom <-tbl.gene$chr
tbl.regions <- data.frame(chrom=chrom, start=min.loc, end=max.loc, stringsAsFactors=FALSE)
mtx <- loadExpressionData(trenaProject, "FilteredLengthScaledTPM8282018-vsn")
build.spec <- list(title=sprintf("%s model %d", getTargetGene(trenaProject), 1),
type="footprint.database",
regions=tbl.regions,
geneSymbol=getTargetGene(trenaProject),
tss=tss,
matrix=mtx,
db.host="khaleesi.systemsbiology.net",
databases=list("brain_hint_20"),
motifDiscovery="builtinFimo",
tfPool=allKnownTFs(identifierType="geneSymbol"),
tfMapping="MotifDB",
tfPrefilterCorrelation=0.1,
annotationDbFile=dbfile(org.Hs.eg.db),
orderModelByColumn="pearsonCoeff",
solverNames=c("lasso", "lassopv", "pearson", "randomForest", "ridge", "spearman"))
#------------------------------------------------------------
# use the above build.spec: a small region, high correlation
# required, MotifDb for motif/tf lookup
#------------------------------------------------------------
fpBuilder <- FootprintDatabaseModelBuilder("hg38", getTargetGene(trenaProject), build.spec, quiet=TRUE)
x <- build(fpBuilder)
xyz <- "back from build"
} # buildFootprintModel
#------------------------------------------------------------------------------------------------------------------------
setupAddTrack <- function(trenaProject, session, input, output)
{
observeEvent(input$addTrack, {
newTrackName <- input$addTrack
if(newTrackName == "") return()
printf(" addTrack event: %s", newTrackName);
displayTrack(trenaProject, session, newTrackName)
later(function() {updateSelectInput(session, "addTrack", selected=character(0))}, 1)
})
} # setupAddTrack
#------------------------------------------------------------------------------------------------------------------------
displayTrack <- function(trenaProject, session, trackName)
{
printf("--- displayTrack('%s')", trackName)
if(grepl(".variants", trackName, ignore.case=TRUE))
displayBedTrack(trenaProject, session, trackName)
if(grepl("gwas", trackName, ignore.case=TRUE))
displayBedTrack(trenaProject, session, trackName)
if(trackName == "enhancers")
displayEnhancersTrack(trenaProject, session)
if(trackName == "dhs")
displayEncodeDhsTrack(trenaProject, session)
} # displayTrack
#------------------------------------------------------------------------------------------------------------------------
displayEnhancersTrack <- function(trenaProject, session)
{
tbl.enhancers <- getEnhancers(trenaProject)
tbl.tmp <- tbl.enhancers[, c("chrom", "start", "end", "combinedScore")]
loadBedGraphTrack(session, "GeneHancer", tbl.tmp, color="black", trackHeight=25, autoscale=FALSE, min=0, max=20)
} # displayEnhancersTrack
#------------------------------------------------------------------------------------------------------------------------
displayEncodeDhsTrack <- function(trenaProject, session)
{
tbl.dhs <- getEncodeDHS(trenaProject)
tbl.tmp <- tbl.dhs[, c("chrom", "chromStart", "chromEnd", "score")]
colnames(tbl.tmp) <- c("chrom", "start", "end", "score")
loadBedGraphTrack(session, "DHS", tbl.tmp, color="black", trackHeight=25, autoscale=TRUE)
} # displayEncodeDhsTrack
#------------------------------------------------------------------------------------------------------------------------
displayGWASTrack <- function(trenaProject, session, trackName)
{
variantDatasetNames <- getVariantDatasetNames(trenaProject)
printf("want to see trackName (%s) among variantDatasetNames", trackName)
print(paste(variantDatasetNames, collapse=", "))
if(trackName %in% variantDatasetNames){
printf(" --- found %s to display", trackName)
printf(" want to restrict variant table to this region: %s", state$chromLocRegion)
loc <- parseChromLocString(state$chromLocRegion)
tbl.variant <- getVariantDataset(trenaProject, trackName)
if(trackName == "GWAS.snps"){
tbl.variant <- tbl.variant[, c("chrom", "start", "end", "pScore")]
colnames(tbl.variant) <- c("chrom", "start", "end", "value")
}
tbl.variant <- subset(tbl.variant, chrom==loc$chrom & start >= loc$start & end <= loc$end)
printf("%d regions in %s", nrow(tbl.variant), trackName)
showNotification(sprintf("%s: %d genomic features", trackName, nrow(tbl.variant)))
if(nrow(tbl.variant) > 0)
loadBedGraphTrack(session, trackName, tbl.variant, color="red", trackHeight=25, autoscale=TRUE) # , min=0, max=10)
} # trackName found in variant data sets
} # displayGWASTrack
#------------------------------------------------------------------------------------------------------------------------
displayBedTrack <- function(trenaProject, session, trackName)
{
variantDatasetNames <- getVariantDatasetNames(trenaProject)
printf("want to see trackName (%s) among variantDatasetNames", trackName)
print(paste(variantDatasetNames, collapse=", "))
if(trackName %in% variantDatasetNames){
printf(" --- found %s to display", trackName)
printf(" want to restrict variant table to this region: %s", state$chromLocRegion)
loc <- parseChromLocString(state$chromLocRegion)
tbl.variant <- getVariantDataset(trenaProject, trackName)
tbl.variant <- subset(tbl.variant, chrom==loc$chrom & start >= loc$start & end <= loc$end)
printf("%d regions in %s", nrow(tbl.variant), trackName)
showNotification(sprintf("%s: %d genomic features", trackName, nrow(tbl.variant)))
if(nrow(tbl.variant) > 0)
loadBedTrack(session, trackName, tbl.variant, color="red", trackHeight=25)
} # trackName found in variant data sets
} # displayBedTrack
#------------------------------------------------------------------------------------------------------------------------
setupDisplayRegion <- function(trenaProject, session, input, output)
{
observeEvent(input$displayGenomicRegion, {
requestedRegion <- input$displayGenomicRegion
if(requestedRegion == "") return()
printf(" displayRegion: %s", requestedRegion)
margin <- 5000
loc.string <-switch(requestedRegion,
fullEnhancerRegion = {getGeneEnhancersRegion(trenaProject, 10)},
fullGeneRegion = {getGeneRegion(trenaProject, 20)})
showGenomicRegion(session, loc.string);
later(function() {updateSelectInput(session, "displayGenomicRegion", selected=character(0))}, 1)
})
observeEvent(input$removeUserAddedTracks, {
removeUserAddedTracks(session)
})
} # setupDisplayRegion
#------------------------------------------------------------------------------------------------------------------------
setupBuildModel <- function(trenaProject, session, input, output)
{
observeEvent(input$modelSelector, ignoreInit=TRUE, {
modelName <- isolate(input$modelSelector)
printf("--- new model selected: %s", modelName)
new.table <- state$models[[modelName]]$model
displayModel(session, input, output, new.table, modelName)
})
observe({
x <- input$sidebarCollapsed;
redrawIgvWidget(session)
})
observe({
currentName <- input$modelNameTextInput
expressionMatrixName <- input$expressionSet
allInputsSpecified <- nchar(currentName) >= 1 & nchar(expressionMatrixName) > 2
if(allInputsSpecified)
shinyjs::enable("buildModelButton")
else
shinyjs::disable("buildModelButton")
})
observeEvent(input$buildModelButton, {
getGenomicRegion(session)
state$tbl.chipSeq <- NULL # this will force a fresh database query after model is built
shinyjs::html(id="console", html="", add=FALSE) # clear the console
tryCatch({
withCallingHandlers({buildModel(trenaProject, session, input, output);
model.count <- length(state$models)
new.model.name <- names(state$models)[model.count]
new.table <- state$models[[model.count]]$model
displayModel(session, input, output, new.table, new.model.name)
updateTabItems(session, "sidebarMenu", select="igvAndTable")
},
message=function(m){
shinyjs::html(id="console", html=m$message, add=TRUE)
})
}, error=function(e){
msg <- e$message
print(msg)
showModal(modalDialog(title="trena model building error", msg))
}) # tryCatch
}) # observe buildModelButton
} # setupBuildModel
#------------------------------------------------------------------------------------------------------------------------
buildModel <- function(trenaProject, session, input, output)
{
model.name <- sprintf("trena.model.%s", input$modelNameTextInput)
message(sprintf("about to build '%s'", model.name))
footprint.database.names <- input$footprintDatabases
tracks.to.intersect.with <- input$intersectWithRegions
motifMapping <- isolate(input$motifMapping)
if(tolower(motifMapping) == "motifdb + tfclass")
motifMapping <- c("MotifDb", "TFClass")
expressionMatrixName <- input$expressionSet
full.roi <- state$chromLocRegion
chrom.loc <- trena::parseChromLocString(full.roi)
message(sprintf(" fpdb: %s", paste(footprint.database.names, collapse=", ")))
message(sprintf(" roi: %s", full.roi))
message(sprintf(" mtx: %s", expressionMatrixName))
message(printf(" intersect with: %s", paste(tracks.to.intersect.with, collapse=",")))
tbl.gene <- subset(state$tbl.transcripts, moleculetype=="gene")[1,]
strand <- tbl.gene$strand
tss <- tbl.gene$start
if(strand == "-")
tss <- tbl.gene$endpos
run.trenaSGM(trenaProject,
model.name,
chrom.loc$chrom, chrom.loc$start, chrom.loc$end,
tss,
expressionMatrixName,
tracks.to.intersect.with,
footprint.database.names,
motifMapping)
} # buildModel
#------------------------------------------------------------------------------------------------------------------------
run.trenaSGM <- function(trenaProject,
model.name,
chromosome, start.loc, end.loc,
tss,
expression.matrix.name,
tracks.to.intersect.with,
footprint.database.names,
motifMapping)
{
message(sprintf("--- entering run.trenaSGM"))
# no search for overlaps just yet: ignore "tracks.to.intersect.with"
#browser()
tbl.regions <- buildRegionsTable(tracks.to.intersect.with, chromosome, start.loc, end.loc,
state$tbl.enhancers, state$tbl.dhs)
#tbl.regions <- data.frame(chrom=chromosome, start=start.loc, end=end.loc, stringsAsFactors=FALSE)
mtx <- getExpressionMatrix(trenaProject, expression.matrix.name)
geneSymbol <- getTargetGene(trenaProject)
for(r in seq_len(nrow(tbl.regions))){
message(sprintf("tbl.regions, width: %d", with(tbl.regions[r,], end - start)))
}
build.spec <- list(title=model.name,
type="footprint.database",
regions=tbl.regions,
geneSymbol=getTargetGene(trenaProject),
tss=tss,
matrix=mtx,
db.host="khaleesi.systemsbiology.net",
databases=footprint.database.names,
motifDiscovery="builtinFimo",
tfPool=allKnownTFs(identifierType="geneSymbol"),
tfMapping=motifMapping,
tfPrefilterCorrelation=0.2,
annotationDbFile=dbfile(org.Hs.eg.db),
orderModelByColumn="pearsonCoeff",
solverNames=c("lasso", "lassopv", "pearson", "randomForest", "ridge", "spearman"))
# save(build.spec, file=sprintf("%s.buildSpec.RData", model.name))
#------------------------------------------------------------
# use the above build.spec: a small region, high correlation
# required, MotifDb for motif/tf lookup
#------------------------------------------------------------
fpBuilder <- FootprintDatabaseModelBuilder("hg38", getTargetGene(trenaProject), build.spec, quiet=FALSE)
x <- build(fpBuilder)
message(sprintf("back from build, top 10 tfs:"))
message(head(x$model, n=10))
#save(x, file=sprintf("%s.results.RData", model.name))
state$models[[model.name]] <- x
} # run.trenaSGM
#------------------------------------------------------------------------------------------------------------------------
buildRegionsTable <- function(tracks.to.intersect.with, chromosome, start.loc, end.loc, tbl.enhancers, tbl.dhs)
{
if(tracks.to.intersect.with == "allDNAForFootprints")
return(data.frame(chrom=chromosome, start=start.loc, end=end.loc, stringsAsFactors=FALSE))
gr.region <- GRanges(seqnames=chromosome, IRanges(start.loc, end.loc))
gr.enhancers <- GRanges(tbl.enhancers)
gr.dhs <- GRanges(tbl.dhs)
# strip off metadata so that the regions can be combined
mcols(gr.region) <- NULL
mcols(gr.enhancers) <- NULL
mcols(gr.dhs) <- NULL
gr.enhancers.or.dhs <- c(gr.enhancers, gr.dhs)
gr.enhancers.and.dhs <- GenomicRanges::intersect(gr.enhancers, gr.dhs)
tbl.out <- switch(tracks.to.intersect.with,
genehancer = {
tbl.ov <- as.data.frame(findOverlaps(gr.enhancers, gr.region, type="any"))
indices <- unique(tbl.ov[,1])
as.data.frame(gr.enhancers[indices])
},
encodeDHS = {
tbl.ov <- as.data.frame(findOverlaps(gr.dhs, gr.region, type="any"))
indices <- unique(tbl.ov[,1])
as.data.frame(gr.dhs[indices])
},
geneHancerOrEncode = {
tbl.ov <- as.data.frame(findOverlaps(gr.enhancers.or.dhs, gr.region, type="any"))
indices <- unique(tbl.ov[,1])
as.data.frame(gr.enhancers.or.dhs[indices], row.names=NULL)
},
geneHancerAndEncode = {
tbl.ov <- as.data.frame(findOverlaps(gr.enhancers.and.dhs, gr.region, type="any"))
indices <- unique(tbl.ov[,1])
as.data.frame(gr.enhancers.and.dhs[indices], row.names=NULL)
})
tbl.out <- tbl.out[, 1:3]
colnames(tbl.out) <- c("chrom", "start", "end")
tbl.out$chrom <- as.character(tbl.out$chrom)
tbl.out$start <- as.numeric(tbl.out$start)
tbl.out$end <- as.numeric(tbl.out$end)
return(tbl.out)
} # buildRegionsTable
#------------------------------------------------------------------------------------------------------------------------
test_buildRegionsTable <- function()
{
library(RUnit)
variables.loaded <- load("buildRegionsTable.sampleData.RData")
stopifnot(all(c("chromosome", "start.loc", "end.loc", "tbl.dhs", "tbl.enhancers") %in% variables.loaded))
intersection.options <- c("genehancer", "encodeDHS", "geneHancerOrEncode",
"geneHancerAndEncode", "allDNAForFootprints")
tbl.regions <- buildRegionsTable("allDNAForFootprints", chromosome, start.loc, end.loc, tbl.enhancers, tbl.dhs)
checkEquals(colnames(tbl.regions), c("chrom", "start", "end"))
checkEquals(unlist(lapply(tbl.regions, class), use.names=FALSE), c("character", "numeric", "numeric"))
checkEquals(dim(tbl.regions), c(1, 3))
tbl.regions <- buildRegionsTable("genehancer", chromosome, start.loc, end.loc, tbl.enhancers, tbl.dhs)
checkEquals(colnames(tbl.regions), c("chrom", "start", "end"))
checkEquals(unlist(lapply(tbl.regions, class), use.names=FALSE), c("character", "numeric", "numeric"))
checkEquals(dim(tbl.regions), c(32, 3))
tbl.regions <- buildRegionsTable("encodeDHS", chromosome, start.loc, end.loc, tbl.enhancers, tbl.dhs)
checkEquals(colnames(tbl.regions), c("chrom", "start", "end"))
checkEquals(unlist(lapply(tbl.regions, class), use.names=FALSE), c("character", "numeric", "numeric"))
checkEquals(dim(tbl.regions), c(2541, 3))
tbl.regions <- buildRegionsTable("geneHancerOrEncode", chromosome, start.loc, end.loc, tbl.enhancers, tbl.dhs)
checkEquals(colnames(tbl.regions), c("chrom", "start", "end"))
checkEquals(unlist(lapply(tbl.regions, class), use.names=FALSE), c("character", "numeric", "numeric"))
checkEquals(dim(tbl.regions), c(2573, 3))
tbl.regions <- buildRegionsTable("geneHancerAndEncode", chromosome, start.loc, end.loc, tbl.enhancers, tbl.dhs)
checkEquals(colnames(tbl.regions), c("chrom", "start", "end"))
checkEquals(unlist(lapply(tbl.regions, class), use.names=FALSE), c("character", "numeric", "numeric"))
checkEquals(dim(tbl.regions), c(341, 3))
} # test_buildRegionsTable
#------------------------------------------------------------------------------------------------------------------------
# beautify the data.frame, display it in the UI DataTable, update the modelSelector pulldown
displayModel <- function(session, input, output, tbl.model, new.model.name)
{
printf("--- entering displayModel: %s", new.model.name)
print(dim(tbl.model))
tf.names <- tbl.model$gene
tbl.model <- tbl.model[, -1]
if("lassoPValue" %in% colnames(tbl.model))
tbl.model <- roundNumericColumns(tbl.model, 4, "lassoPValue")
rownames(tbl.model) <- tf.names
max.model.rows <- MAX.TF.COUNT
if(nrow(tbl.model) > max.model.rows)
tbl.model <- tbl.model[1:max.model.rows,]
output$table = DT::renderDataTable(tbl.model,
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)
))
updateSelectInput(session, "modelSelector",
choices=names(state$models),
selected=new.model.name)
} # displayModel
#------------------------------------------------------------------------------------------------------------------------
dispatch.rowClickInModelTable <- function(trenaProject, session, input, output, selectedTableRow)
{
#current.model.name <- isolate(input$modelSelector)
#if(current.model.name %in% ls(state$models)){
# printf("tf: %s", tf.name)
current.model.name <- isolate(input$modelSelector)
tf.names <- state$models[[current.model.name]]$model$gene
if(length(tf.names) > MAX.TF.COUNT) tf.names <- tf.names[1:MAX.TF.COUNT]
tf.name <- tf.names[selectedTableRow]
action.name <- isolate(input$selectRowAction)
expression.matrix.name <- isolate(input$expressionSet)
#printf("%s of model %s, expression.set %s: %s", tf.name, current.model.name, expression.matrix.name, action.name)
# browser()
xyz <- "botton of dispatch.rowClick"
if(action.name == "Footprints"){
tbl.fp <- state$models[[current.model.name]]$regulatoryRegions
tbl.fp.tf <- subset(tbl.fp, geneSymbol==tf.name)
dups <- which(duplicated(tbl.fp.tf$loc))
if(length(dups) > 0)
tbl.fp.tf <- tbl.fp.tf[-dups,]
tbl.tmp <- tbl.fp.tf[ c("chrom", "fp_start", "fp_end", "shortMotif")]
colnames(tbl.tmp) <- c("chrom", "start", "end", "name")
state$colorNumber <- (state$colorNumber %% totalColorCount) + 1
next.color <- colors[state$colorNumber]
loadBedTrack(session, sprintf("FP-%s", tf.name), tbl.tmp, color=next.color, trackHeight=25)
} # if footprints
if(action.name == "ChIP-seq hits"){
full.roi <- state$chromLocRegion
chrom.loc <- trena::parseChromLocString(full.roi)
if(is.null(state$tbl.chipSeq)){
showNotification("retrieving ChIP-seq data from database (100)...", duration=100, closeButton=TRUE)
tbl.chipSeq <- with(chrom.loc, getChipSeq(trenaProject, chrom, start, end, tf.names))
#save(tbl.chipSeq, file="tbl.chipSeq.RData")
state$tbl.chipSeq <- tbl.chipSeq
hit.count <- nrow(state$tbl.chipSeq)
printf("chipSeq hit.count: %d", hit.count)
showNotification(sprintf("ChIP-seq hits across all TFs in this model: %d", hit.count))
}
tbl.hits <- subset(state$tbl.chipSeq, tf == tf.name)
showNotification(sprintf("ChIP-seq hits for %s: %d", tf.name, nrow(tbl.hits)), type="message")
if(nrow(tbl.hits) > 0){
tbl.tmp <- tbl.hits[, c("chrom", "start", "endpos", "name")]
colnames(tbl.tmp) <- c("chrom", "start", "end", "name")
state$colorNumber <- (state$colorNumber %% totalColorCount) + 1
next.color <- colors[state$colorNumber]
loadBedTrack(session, sprintf("Cs-%s", tf.name), tbl.tmp, color=next.color, trackHeight=25)
}
} # ChIP-seq hits
} # dispatch.rowClickInModelTable
#------------------------------------------------------------------------------------------------------------------------
display.chipseq.track <- function(session, input, output, tf)
{
} # display.chipseq.track
#------------------------------------------------------------------------------------------------------------------------
display.footprint.track <- function(session, input, output, tf)
{
model.name <- isolate(input$modelSelector)
} # display.footprint.track
#------------------------------------------------------------------------------------------------------------------------
loadAndDisplayRelevantVariants <- function(trenaProject, session, newGene)
{
variant.filenames <- getVariantDatasetNames(trenaProject)
short.names <- names(variant.filenames)
file.paths <- unlist(variant.filenames, use.names=FALSE)
vcf.file.indices <- grep(".vcf", short.names, ignore.case=TRUE)
thisGene.indices <- grep(newGene, short.names, ignore.case=TRUE)
final.indices <- intersect(vcf.file.indices, thisGene.indices)
if(length(final.indices) == 0)
return()
current.gene.vcf.files <- file.paths[final.indices]
for(i in seq_len(length(current.gene.vcf.files))){
vcfFile <- current.gene.vcf.files[i]
vcfData <- readVcf(vcfFile)
loadVcfTrack(session, "vcf", vcfData)
}
} # loadAndDisplayRelevantVariants
#------------------------------------------------------------------------------------------------------------------------
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.