R/NetworkView.R
In PriceLab/TrenaViz: TrenaViz
Defines functions
.addGeneModelLayout
.geneRegulatoryModelToGraph
.standardizeRegulatoryRegionsTable
.standardizeModelTable
NetworkView
Documented in
NetworkView
#' import shiny
#' import cyjShiny
#' import TrenaProject
#' import graph
#' @name NetworkView
#' @rdname NetworkView
#' @aliases NetworkView
#------------------------------------------------------------------------------------------------------------------------
# library(TrenaProject)
# library(cyjShiny)
#------------------------------------------------------------------------------------------------------------------------
.NetworkView <- setClass("NetworkView",
representation = representation(
quiet="logical",
targetGene="character",
tss="numeric",
tbl.model="data.frame",
tbl.regulatoryRegions="data.frame",
state="environment")
)
#------------------------------------------------------------------------------------------------------------------------
setGeneric('getGraph', signature='obj', function(obj) standardGeneric('getGraph'))
#------------------------------------------------------------------------------------------------------------------------
setMethod('getGraph', 'NetworkView',
function(obj){
tbl.nodes <- data.frame(id=c("A", "B", "C"),
type=c("kinase", "TF", "glycoprotein"),
lfc=c(1, 1, 1),
count=c(0, 0, 0),
stringsAsFactors=FALSE)
tbl.edges <- data.frame(source=c("A", "B", "C"),
target=c("B", "C", "A"),
interaction=c("phosphorylates", "synthetic lethal", "unknown"),
stringsAsFactors=FALSE)
graph.json <- dataFramesToJSON(tbl.edges, tbl.nodes)
targetGene <- obj@targetGene
tbl.model <- obj@tbl.model
tbl.reg <- obj@tbl.regulatoryRegions
tss <- obj@tss
g <- .geneRegulatoryModelToGraph(targetGene, tss, tbl.model, tbl.reg)
g <- .addGeneModelLayout(g, xPos.span=1500)
g
})
#------------------------------------------------------------------------------------------------------------------------
#' Create an NetworkView object
#'
#' @description
#' a shiny app
#'
#' @rdname NetworkView
#'
#' @param organism A character string, one of the supported species names: hsapiens, mmuscuulus
#' @param genome A character string, one of the supported genome builds: hg38, mm10
#' @param quiet A logical indicating whether or not the Trena object should print output
#'
#' @return An object of the NetworkView class
#'
#' @export
#'
NetworkView <- function(targetGene, tss, tbl.model, tbl.regulatoryRegions, quiet=TRUE)
{
state <- new.env(parent=emptyenv())
.NetworkView(targetGene=targetGene,
tss=tss,
tbl.model=tbl.model,
tbl.regulatoryRegions=tbl.regulatoryRegions,
state=state,
quiet=quiet)
} # NetworkView
#------------------------------------------------------------------------------------------------------------------------
setMethod("show", "NetworkView",
function(object){
cat(paste("a NetworkView object from the TrenaViz package:", "\n"))
cat(sprintf(" targetGene: %s\n", obj@targetGene))
cat(sprintf(" tss: %s\n", obj@tss))
cat(sprintf(" tbl.model: %d rows, %d columns\n", nrow(obj@tbl.model), ncol(obj@tbl.model)))
cat(sprintf(" tbl.regulatoryRegions: %d rows, %d columns\n", nrow(obj@tbl.regulatoryRegions),
ncol(obj@tbl.regulatoryRegions)))
})
#------------------------------------------------------------------------------------------------------------------------
#' create and return the control-rich UI
#'
#' @rdname createPage
#' @aliases createPage
#'
#' @param obj An object of class NetworkView
#'
#' @export
#'
setMethod("createPage", "NetworkView",
function(obj) {
fluidPage(id="networkViewPageContent",
fluidRow(
actionButton(inputId="fitNetworkButton", label="Fit"),
actionButton(inputId="fitSelectedNodesButton", label="Fit Selection"),
actionButton(inputId="removeNetworkButton", label="Remove Graph"),
actionButton(inputId="genomicLayoutButton", label="GenomicLayout")
),
fluidRow(column(width=12, cyjShinyOutput('cyjShiny')))
)
#cyjShinyOutput('cyjShiny', height=400)
})
#------------------------------------------------------------------------------------------------------------------------
#' display the page
#'
#' @rdname displayPage
#' @aliases displayPage
#'
#' @param obj An object of class NetworkView
#' @param tf character string, the geneSymbol name of the transcription factor
#'
#' @export
#'
setMethod("displayPage", "NetworkView",
function(obj){
printf("NetworkView displayPage")
removeUI(selector="#networkViewPageContent", immediate=TRUE)
insertUI(selector="#networkViewPage", where="beforeEnd", createPage(obj), immediate=TRUE)
#js$cyjSetupResize();
js$cyjShinySetWidth();
later(function(){fit(session, 300)}, 1000)
})
#------------------------------------------------------------------------------------------------------------------------
#' add shiny event handlers
#'
#' @rdname addEventHandlers
#' @aliases addEventHandlers
#'
#' @param obj An object of class NetworkView
#' @param session a Shiny session object
#' @param input a Shiny input object
#' @param output a Shiny output object
#'
#' @export
#'
setMethod("addEventHandlers", "NetworkView",
function(obj, session, input, output){
printf("--- NetworkView::addEventHandlers")
obj@state$session <- session
obj@state$input <- input
obj@state$output <- output
observeEvent(input$fitNetworkButton, ignoreInit=TRUE, {
fit(session, 80)
})
observeEvent(input$fitSelectedNodesButton, ignoreInit=TRUE, {
fitSelected(session, 80)
})
observeEvent(input$removeNetworkButton, ignoreInit=TRUE, {
removeGraph(session)
})
observeEvent(input$genomicLayoutButton, ignoreInit=TRUE, {
setNodePositions(session, obj@state$tbl.pos)
})
observeEvent(input$viewNetworkButton, ignoreInit=FALSE, {
printf("view network")
updateTabItems(session, "sidebarMenu", selected="networkViewTab")
# displayPage(obj)
xyz <- "observing viewNetworkButton"
output$cyjShiny <- renderCyjShiny({
printf("--- renderCyjShiny, triggered by viewNetworkButton")
style.file <- system.file(package="TrenaViz", "extdata", "trenaModelStyle.js")
g <- getGraph(obj)
obj@state$g <- g
print(g)
graph.json <- graphNELtoJSON(g)
xPos <- nodeData(g, attr="xPos")
yPos <- nodeData(g, attr="yPos")
tbl.pos <- data.frame(id=names(xPos), x=as.numeric(xPos), y=as.numeric(yPos), stringsAsFactors=FALSE)
obj@state$tbl.pos <- tbl.pos
cyjShiny(graph.json, layoutName="cola", styleFile=style.file, width=1000, height=1000)
})
})
}) # addEventHandlers
#------------------------------------------------------------------------------------------------------------------------
# by example:
#
# the incoming tbl.model presents these challenges:
#
# gene betaLasso lassoPValue pearsonCoeff rfScore betaRidge spearmanCoeff bindingSites
# 6 E2F3 0 7.124847e-07 0.8683105 2.936714 0.04945335 0.8149973 NA
# 45 HOXC13 0 3.987483e-02 -0.8640875 2.457541 -0.01531601 -0.7659080 NA
# 97 ZNF263 0 6.236969e-01 0.9003067 2.134046 0.04104303 0.6360153 NA
# 70 PRDM4 0 1.000000e+00 0.8984506 1.900193 0.03627523 0.7405583 NA
#
# and for which we want these results (first 4 rows only)
#
# tf pearson spearman betaLasso randomForest
# 6 E2F3 0.8683105 0.8149973 0 2.936714
# 45 HOXC13 -0.8640875 -0.7659080 0 2.457541
# 97 ZNF263 0.9003067 0.6360153 0 2.134046
# 70 PRDM4 0.8984506 0.7405583 0 1.900193
.standardizeModelTable <- function(tbl.model)
{
required.colNames <- c("tf", "pearson", "spearman", "betaLasso", "randomForest")
colnames.in <- tolower(colnames(tbl.model))
gene.col <- grep("^gene$", colnames.in)
if(length(gene.col) > 0)
colnames(tbl.model)[gene.col] <- "tf"
pearson.col <- grep("pearson", colnames.in)
if(length(pearson.col) > 0)
colnames(tbl.model)[pearson.col] <- "pearson"
spearman.col <- grep("spearman", colnames.in)
if(length(spearman.col) > 0)
colnames(tbl.model)[spearman.col] <- "spearman"
betaLasso.col <- grep("betalasso", colnames.in)
if(length(betaLasso.col) > 0)
colnames(tbl.model)[betaLasso.col] <- "betaLasso"
rf.1.col <- grep("forest", colnames.in)
rf.2.col <- grep("rfscore", colnames.in)
if(length(rf.1.col) > 0)
colnames(tbl.model)[rf.1.col] <- "randomForest"
if(length(rf.2.col) > 0)
colnames(tbl.model)[rf.2.col] <- "randomForest"
tbl.out <- tbl.model[, required.colNames]
tbl.out
} # .standardizeModelTable
#------------------------------------------------------------------------------------------------------------------------
# by example:
#
# one instance of the incoming tbl.reg presents these challenges:
#
# motifName loc fp_start fp_end type name length strand sample_id method provenance score1 score2 score3 score4 score5 score6 chrom database shortMotif geneSymbol pubmedID organism source
# Hsapiens-HOCOMOCOv10-CLOCK_HUMAN.H10MO.D chr3:128077447-128077466 128077441 128077451 motif.in.footprint Hsapiens-HOCOMOCOv10-CLOCK_HUMAN.H10MO.D 20 + ENCSR000EMT HINT lymphoblast_hint_16.minid 12 13.02250 1.81e-05 NA NA NA chr3 lymphoblast_hint_16 CLOCK_HUMAN.H10MO.D CLOCK 26586801 Hsapiens MotifDb
# Hsapiens-HOCOMOCOv10-PURA_HUMAN.H10MO.D chr3:128417965-128417981 128417972 128417989 motif.in.footprint Hsapiens-HOCOMOCOv10-PURA_HUMAN.H10MO.D 17 - ENCSR000EJK HINT lymphoblast_hint_20.minid 12 12.04400 3.25e-05 NA NA NA chr3 lymphoblast_hint_20 PURA_HUMAN.H10MO.D PURA 26586801 Hsapiens MotifDb
# Hsapiens-jaspar2016-HOXC11-MA0651.1 chr3:128617604-128617614 128617598 128617621 motif.in.footprint Hsapiens-jaspar2016-HOXC11-MA0651.1 11 - ENCSR000DBZ HINT lymphoblast_hint_20.minid 32 11.10000 7.99e-05 NA NA NA chr3 lymphoblast_hint_20 MA0651.1 HOXC11 24194598 Hsapiens MotifDb
# Hsapiens-jaspar2016-SP4-MA0685.1 chr3:128487237-128487253 128487253 128487267 motif.in.footprint Hsapiens-jaspar2016-SP4-MA0685.1 17 - ENCSR000EJE HINT lymphoblast_hint_16.minid 24 4.01124 8.85e-05 NA NA NA chr3 lymphoblast_hint_16 MA0685.1 SP4 24194598 Hsapiens MotifDb
# Hsapiens-jaspar2016-ZBTB7A-MA0750.1 chr3:128617856-128617867 128617847 128617892 motif.in.footprint Hsapiens-jaspar2016-ZBTB7A-MA0750.1 12 + ENCSR000DCA HINT lymphoblast_hint_16.minid 20 15.76400 2.28e-06 NA NA NA chr3 lymphoblast_hint_16 MA0750.1 ZBTB7A 24194598 Hsapiens MotifDb
#
# from which we wish to extract:
#
# chrom start end tf motif
# 1 chr3 128483072 128483461 MAZ Hsapiens-HOCOMOCOv10-MAZ_HUMAN.H10MO.A
# 2 chr3 128483072 128483461 SP4 Hsapiens-HOCOMOCOv10-SP4_HUMAN.H10MO.D
# 3 chr3 128483072 128483461 SP2 Hsapiens-HOCOMOCOv10-SP2_HUMAN.H10MO.C
# 4 chr3 128483072 128483461 SP3 Hsapiens-HOCOMOCOv10-SP3_HUMAN.H10MO.B
# 5 chr3 128483072 128483461 SP3 Hsapiens-SwissRegulon-SP3.SwissRegulon
# 6 chr3 128483072 128483461 SP1 Hsapiens-HOCOMOCOv10-SP1_HUMAN.H10MO.C
#
# and we want
# chrom start end name distance motifName
# chr3 128483072 128483461 MAZ Hsapiens-HOCOMOCOv10-MAZ_HUMAN.H10MO.A
#
# regRegions.names <- unlist(lapply(1:nrow(tbl.reg), function(i){
# distance.from.tss <- tbl.reg$distance.from.tss[i]
# region.size <- nchar(tbl.reg$match[i])
# motif.name <- tbl.reg$motifName[i]
# if(distance.from.tss < 0)
# sprintf("%s.fp.downstream.%05d.L%d.%s", targetGene, abs(distance.from.tss), region.size, motif.name)
# else
# sprintf("%s.fp.upstream.%05d.L%d.%s", targetGene, abs(distance.from.tss), region.size, motif.name)
# }))
#
# tbl.reg$regionName <- regRegions.names
# all.nodes <- unique(c(targetGene, tfs, regRegions.names))
# g <- addNode(all.nodes, g)
#
# nodeData(g, targetGene, "type") <- "targetGene"
# nodeData(g, tfs, "type") <- "TF"
# nodeData(g, regRegions.names, "type") <- "regulatoryRegion"
# nodeData(g, all.nodes, "label") <- all.nodes
# nodeData(g, regRegions.names, "label") <- tbl.reg$motifName
# nodeData(g, regRegions.names, "distance") <- tbl.reg$distance
# nodeData(g, regRegions.names, "motif") <- tbl.reg$motifName
#
.standardizeRegulatoryRegionsTable <- function(tbl.reg, targetGene, tss)
{
locs <- lapply(tbl.reg$loc, parseChromLocString)
tbl.rough <- do.call(rbind, lapply(locs, as.data.frame))
tbl.rough$chrom <- as.character(tbl.rough$chrom)
tbl.rough <- cbind(tbl.rough, tbl.reg[, c("motifName", "fp_start", "fp_end", "geneSymbol")])
make.name <- function(tss, start, tf){
distance.from.tss <- tss - start
sprintf("%s:%d:%s", targetGene, distance.from.tss, tf)
}
regulatory.region.names <- unlist(lapply(1:nrow(tbl.reg),
function(i) make.name(tss, tbl.rough$fp_start[i], tbl.rough$geneSymbol[i])))
tbl.rough$name <- regulatory.region.names
tbl.rough$distance <- tss - tbl.rough$fp_start
tbl.rough$targetGene <- targetGene
tbl.out <- tbl.rough[, c("chrom", "fp_start", "fp_end", "distance", "name", "targetGene", "geneSymbol", "motifName")]
colnames(tbl.out) <- c("chrom", "start", "end", "distance", "name", "targetGene", "tf", "motif")
rownames(tbl.out) <- NULL
tbl.out
} # .standardizeRegulatoryRegionsTable
#------------------------------------------------------------------------------------------------------------------------
.geneRegulatoryModelToGraph <- function(targetGene, tss, tbl.model, tbl.reg)
{
xyz <- ".geneRegulatoryModelToGraph"
tbl.model <- .standardizeModelTable(tbl.model)
tbl.reg <- .standardizeRegulatoryRegionsTable(tbl.reg, targetGene, tss)
required.geneModelColumnNames <- c("tf", "pearson", "spearman", "betaLasso", "randomForest")
required.regulatoryRegionsColumnNames <- c("chrom", "start", "end", "distance", "name", "targetGene", "tf", "motif")
stopifnot(all(required.geneModelColumnNames %in% colnames(tbl.model)))
stopifnot(all(required.regulatoryRegionsColumnNames %in% colnames(tbl.reg)))
printf("genes: %d, %d occurences of %d motifs", length(tbl.model$tf), length(tbl.reg$motif),
length(unique(tbl.reg$motif)))
g <- graphNEL(edgemode = "directed")
nodeDataDefaults(g, attr = "type") <- "undefined" # targetGene, tf, footprint
nodeDataDefaults(g, attr = "label") <- "default node label"
nodeDataDefaults(g, attr = "distance") <- 0
nodeDataDefaults(g, attr = "pearson") <- 0
nodeDataDefaults(g, attr = "randomForest") <- 0
nodeDataDefaults(g, attr = "betaLasso") <- 0
nodeDataDefaults(g, attr = "motif") <- ""
nodeDataDefaults(g, attr = "xPos") <- 0
nodeDataDefaults(g, attr = "yPos") <- 0
edgeDataDefaults(g, attr = "edgeType") <- "undefined"
tfs <- tbl.model$tf
all.nodes <- unique(c(targetGene, tfs, tbl.reg$name))
g <- addNode(all.nodes, g)
nodeData(g, targetGene, "type") <- "targetGene"
nodeData(g, tfs, "type") <- "TF"
nodeData(g, tbl.reg$name, "type") <- "regulatoryRegion"
nodeData(g, all.nodes, "label") <- all.nodes
xyz <- "NetworkView assiging graph node data"
nodeData(g, tbl.reg$name, "label") <- tbl.reg$motif
nodeData(g, tbl.reg$name, "distance") <- tbl.reg$distance
nodeData(g, tbl.reg$name, "motif") <- tbl.reg$motifName
nodeData(g, tfs, "pearson") <- tbl.model$pearson
nodeData(g, tfs, "betaLasso") <- tbl.model$betaLasso
nodeData(g, tfs, "randomForest") <- tbl.model$randomForest
g <- addEdge(tbl.reg$tf, tbl.reg$name, g)
edgeData(g, tbl.reg$tf, tbl.reg$name, "edgeType") <- "bindsTo"
g <- graph::addEdge(tbl.reg$name, targetGene, g)
edgeData(g, tbl.reg$name, targetGene, "edgeType") <- "regulatorySiteFor"
g
} # .geneRegulatoryModelToGraph
#------------------------------------------------------------------------------------------------------------------------
.addGeneModelLayout <- function(g, xPos.span=1500)
{
all.distances <- sort(unique(unlist(nodeData(g, attr='distance'), use.names=FALSE)))
print(all.distances)
fp.nodes <- nodes(g)[which(unlist(nodeData(g, attr="type"), use.names=FALSE) == "regulatoryRegion")]
tf.nodes <- nodes(g)[which(unlist(nodeData(g, attr="type"), use.names=FALSE) == "TF")]
targetGene.nodes <- nodes(g)[which(unlist(nodeData(g, attr="type"), use.names=FALSE) == "targetGene")]
# add in a zero in case all of the footprints are up or downstream of the 0 coordinate, the TSS
span.endpoints <- range(c(0, as.numeric(nodeData(g, fp.nodes, attr="distance"))))
span <- max(span.endpoints) - min(span.endpoints)
footprintLayoutFactor <- 1
printf("initial: span: %d footprintLayoutFactor: %f", span, footprintLayoutFactor)
footprintLayoutFactor <- xPos.span/span
#if(span < 600) #
# footprintLayoutFactor <- 600/span
#if(span > 1000)
# footprintLayoutFactor <- span/1000
printf("corrected: span: %d footprintLayoutFactor: %f", span, footprintLayoutFactor)
xPos <- as.numeric(nodeData(g, fp.nodes, attr="distance")) * footprintLayoutFactor
yPos <- 0
nodeData(g, fp.nodes, "xPos") <- xPos
nodeData(g, fp.nodes, "yPos") <- yPos
adjusted.span.endpoints <- range(c(0, as.numeric(nodeData(g, fp.nodes, attr="xPos"))))
printf("raw span of footprints: %d footprintLayoutFactor: %f new span: %8.0f",
span, footprintLayoutFactor, abs(max(adjusted.span.endpoints) - min(adjusted.span.endpoints)))
tfs <- names(which(nodeData(g, attr="type") == "TF"))
for(tf in tfs){
footprint.neighbors <- edges(g)[[tf]]
if(length(footprint.neighbors) > 0){
footprint.positions <- as.integer(nodeData(g, footprint.neighbors, attr="xPos"))
new.xPos <- mean(footprint.positions)
if(is.na(new.xPos)) browser()
if(is.nan(new.xPos)) browser()
#printf("%8s: %5d", tf, new.xPos)
}
else{
new.xPos <- 0
}
nodeData(g, tf, "yPos") <- sample(300:1200, 1)
nodeData(g, tf, "xPos") <- new.xPos
} # for tf
nodeData(g, targetGene.nodes, "xPos") <- 0
nodeData(g, targetGene.nodes, "yPos") <- -200
g
} # .addGeneModelLayout
#------------------------------------------------------------------------------------------------------------------------
PriceLab/TrenaViz documentation built on May 8, 2020, 9:28 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.
Defines functions .addGeneModelLayout .geneRegulatoryModelToGraph .standardizeRegulatoryRegionsTable .standardizeModelTable NetworkView
Documented in NetworkView
#' import shiny
#' import cyjShiny
#' import TrenaProject
#' import graph
#' @name NetworkView
#' @rdname NetworkView
#' @aliases NetworkView
#------------------------------------------------------------------------------------------------------------------------
# library(TrenaProject)
# library(cyjShiny)
#------------------------------------------------------------------------------------------------------------------------
.NetworkView <- setClass("NetworkView",
representation = representation(
quiet="logical",
targetGene="character",
tss="numeric",
tbl.model="data.frame",
tbl.regulatoryRegions="data.frame",
state="environment")
)
#------------------------------------------------------------------------------------------------------------------------
setGeneric('getGraph', signature='obj', function(obj) standardGeneric('getGraph'))
#------------------------------------------------------------------------------------------------------------------------
setMethod('getGraph', 'NetworkView',
function(obj){
tbl.nodes <- data.frame(id=c("A", "B", "C"),
type=c("kinase", "TF", "glycoprotein"),
lfc=c(1, 1, 1),
count=c(0, 0, 0),
stringsAsFactors=FALSE)
tbl.edges <- data.frame(source=c("A", "B", "C"),
target=c("B", "C", "A"),
interaction=c("phosphorylates", "synthetic lethal", "unknown"),
stringsAsFactors=FALSE)
graph.json <- dataFramesToJSON(tbl.edges, tbl.nodes)
targetGene <- obj@targetGene
tbl.model <- obj@tbl.model
tbl.reg <- obj@tbl.regulatoryRegions
tss <- obj@tss
g <- .geneRegulatoryModelToGraph(targetGene, tss, tbl.model, tbl.reg)
g <- .addGeneModelLayout(g, xPos.span=1500)
g
})
#------------------------------------------------------------------------------------------------------------------------
#' Create an NetworkView object
#'
#' @description
#' a shiny app
#'
#' @rdname NetworkView
#'
#' @param organism A character string, one of the supported species names: hsapiens, mmuscuulus
#' @param genome A character string, one of the supported genome builds: hg38, mm10
#' @param quiet A logical indicating whether or not the Trena object should print output
#'
#' @return An object of the NetworkView class
#'
#' @export
#'
NetworkView <- function(targetGene, tss, tbl.model, tbl.regulatoryRegions, quiet=TRUE)
{
state <- new.env(parent=emptyenv())
.NetworkView(targetGene=targetGene,
tss=tss,
tbl.model=tbl.model,
tbl.regulatoryRegions=tbl.regulatoryRegions,
state=state,
quiet=quiet)
} # NetworkView
#------------------------------------------------------------------------------------------------------------------------
setMethod("show", "NetworkView",
function(object){
cat(paste("a NetworkView object from the TrenaViz package:", "\n"))
cat(sprintf(" targetGene: %s\n", obj@targetGene))
cat(sprintf(" tss: %s\n", obj@tss))
cat(sprintf(" tbl.model: %d rows, %d columns\n", nrow(obj@tbl.model), ncol(obj@tbl.model)))
cat(sprintf(" tbl.regulatoryRegions: %d rows, %d columns\n", nrow(obj@tbl.regulatoryRegions),
ncol(obj@tbl.regulatoryRegions)))
})
#------------------------------------------------------------------------------------------------------------------------
#' create and return the control-rich UI
#'
#' @rdname createPage
#' @aliases createPage
#'
#' @param obj An object of class NetworkView
#'
#' @export
#'
setMethod("createPage", "NetworkView",
function(obj) {
fluidPage(id="networkViewPageContent",
fluidRow(
actionButton(inputId="fitNetworkButton", label="Fit"),
actionButton(inputId="fitSelectedNodesButton", label="Fit Selection"),
actionButton(inputId="removeNetworkButton", label="Remove Graph"),
actionButton(inputId="genomicLayoutButton", label="GenomicLayout")
),
fluidRow(column(width=12, cyjShinyOutput('cyjShiny')))
)
#cyjShinyOutput('cyjShiny', height=400)
})
#------------------------------------------------------------------------------------------------------------------------
#' display the page
#'
#' @rdname displayPage
#' @aliases displayPage
#'
#' @param obj An object of class NetworkView
#' @param tf character string, the geneSymbol name of the transcription factor
#'
#' @export
#'
setMethod("displayPage", "NetworkView",
function(obj){
printf("NetworkView displayPage")
removeUI(selector="#networkViewPageContent", immediate=TRUE)
insertUI(selector="#networkViewPage", where="beforeEnd", createPage(obj), immediate=TRUE)
#js$cyjSetupResize();
js$cyjShinySetWidth();
later(function(){fit(session, 300)}, 1000)
})
#------------------------------------------------------------------------------------------------------------------------
#' add shiny event handlers
#'
#' @rdname addEventHandlers
#' @aliases addEventHandlers
#'
#' @param obj An object of class NetworkView
#' @param session a Shiny session object
#' @param input a Shiny input object
#' @param output a Shiny output object
#'
#' @export
#'
setMethod("addEventHandlers", "NetworkView",
function(obj, session, input, output){
printf("--- NetworkView::addEventHandlers")
obj@state$session <- session
obj@state$input <- input
obj@state$output <- output
observeEvent(input$fitNetworkButton, ignoreInit=TRUE, {
fit(session, 80)
})
observeEvent(input$fitSelectedNodesButton, ignoreInit=TRUE, {
fitSelected(session, 80)
})
observeEvent(input$removeNetworkButton, ignoreInit=TRUE, {
removeGraph(session)
})
observeEvent(input$genomicLayoutButton, ignoreInit=TRUE, {
setNodePositions(session, obj@state$tbl.pos)
})
observeEvent(input$viewNetworkButton, ignoreInit=FALSE, {
printf("view network")
updateTabItems(session, "sidebarMenu", selected="networkViewTab")
# displayPage(obj)
xyz <- "observing viewNetworkButton"
output$cyjShiny <- renderCyjShiny({
printf("--- renderCyjShiny, triggered by viewNetworkButton")
style.file <- system.file(package="TrenaViz", "extdata", "trenaModelStyle.js")
g <- getGraph(obj)
obj@state$g <- g
print(g)
graph.json <- graphNELtoJSON(g)
xPos <- nodeData(g, attr="xPos")
yPos <- nodeData(g, attr="yPos")
tbl.pos <- data.frame(id=names(xPos), x=as.numeric(xPos), y=as.numeric(yPos), stringsAsFactors=FALSE)
obj@state$tbl.pos <- tbl.pos
cyjShiny(graph.json, layoutName="cola", styleFile=style.file, width=1000, height=1000)
})
})
}) # addEventHandlers
#------------------------------------------------------------------------------------------------------------------------
# by example:
#
# the incoming tbl.model presents these challenges:
#
# gene betaLasso lassoPValue pearsonCoeff rfScore betaRidge spearmanCoeff bindingSites
# 6 E2F3 0 7.124847e-07 0.8683105 2.936714 0.04945335 0.8149973 NA
# 45 HOXC13 0 3.987483e-02 -0.8640875 2.457541 -0.01531601 -0.7659080 NA
# 97 ZNF263 0 6.236969e-01 0.9003067 2.134046 0.04104303 0.6360153 NA
# 70 PRDM4 0 1.000000e+00 0.8984506 1.900193 0.03627523 0.7405583 NA
#
# and for which we want these results (first 4 rows only)
#
# tf pearson spearman betaLasso randomForest
# 6 E2F3 0.8683105 0.8149973 0 2.936714
# 45 HOXC13 -0.8640875 -0.7659080 0 2.457541
# 97 ZNF263 0.9003067 0.6360153 0 2.134046
# 70 PRDM4 0.8984506 0.7405583 0 1.900193
.standardizeModelTable <- function(tbl.model)
{
required.colNames <- c("tf", "pearson", "spearman", "betaLasso", "randomForest")
colnames.in <- tolower(colnames(tbl.model))
gene.col <- grep("^gene$", colnames.in)
if(length(gene.col) > 0)
colnames(tbl.model)[gene.col] <- "tf"
pearson.col <- grep("pearson", colnames.in)
if(length(pearson.col) > 0)
colnames(tbl.model)[pearson.col] <- "pearson"
spearman.col <- grep("spearman", colnames.in)
if(length(spearman.col) > 0)
colnames(tbl.model)[spearman.col] <- "spearman"
betaLasso.col <- grep("betalasso", colnames.in)
if(length(betaLasso.col) > 0)
colnames(tbl.model)[betaLasso.col] <- "betaLasso"
rf.1.col <- grep("forest", colnames.in)
rf.2.col <- grep("rfscore", colnames.in)
if(length(rf.1.col) > 0)
colnames(tbl.model)[rf.1.col] <- "randomForest"
if(length(rf.2.col) > 0)
colnames(tbl.model)[rf.2.col] <- "randomForest"
tbl.out <- tbl.model[, required.colNames]
tbl.out
} # .standardizeModelTable
#------------------------------------------------------------------------------------------------------------------------
# by example:
#
# one instance of the incoming tbl.reg presents these challenges:
#
# motifName loc fp_start fp_end type name length strand sample_id method provenance score1 score2 score3 score4 score5 score6 chrom database shortMotif geneSymbol pubmedID organism source
# Hsapiens-HOCOMOCOv10-CLOCK_HUMAN.H10MO.D chr3:128077447-128077466 128077441 128077451 motif.in.footprint Hsapiens-HOCOMOCOv10-CLOCK_HUMAN.H10MO.D 20 + ENCSR000EMT HINT lymphoblast_hint_16.minid 12 13.02250 1.81e-05 NA NA NA chr3 lymphoblast_hint_16 CLOCK_HUMAN.H10MO.D CLOCK 26586801 Hsapiens MotifDb
# Hsapiens-HOCOMOCOv10-PURA_HUMAN.H10MO.D chr3:128417965-128417981 128417972 128417989 motif.in.footprint Hsapiens-HOCOMOCOv10-PURA_HUMAN.H10MO.D 17 - ENCSR000EJK HINT lymphoblast_hint_20.minid 12 12.04400 3.25e-05 NA NA NA chr3 lymphoblast_hint_20 PURA_HUMAN.H10MO.D PURA 26586801 Hsapiens MotifDb
# Hsapiens-jaspar2016-HOXC11-MA0651.1 chr3:128617604-128617614 128617598 128617621 motif.in.footprint Hsapiens-jaspar2016-HOXC11-MA0651.1 11 - ENCSR000DBZ HINT lymphoblast_hint_20.minid 32 11.10000 7.99e-05 NA NA NA chr3 lymphoblast_hint_20 MA0651.1 HOXC11 24194598 Hsapiens MotifDb
# Hsapiens-jaspar2016-SP4-MA0685.1 chr3:128487237-128487253 128487253 128487267 motif.in.footprint Hsapiens-jaspar2016-SP4-MA0685.1 17 - ENCSR000EJE HINT lymphoblast_hint_16.minid 24 4.01124 8.85e-05 NA NA NA chr3 lymphoblast_hint_16 MA0685.1 SP4 24194598 Hsapiens MotifDb
# Hsapiens-jaspar2016-ZBTB7A-MA0750.1 chr3:128617856-128617867 128617847 128617892 motif.in.footprint Hsapiens-jaspar2016-ZBTB7A-MA0750.1 12 + ENCSR000DCA HINT lymphoblast_hint_16.minid 20 15.76400 2.28e-06 NA NA NA chr3 lymphoblast_hint_16 MA0750.1 ZBTB7A 24194598 Hsapiens MotifDb
#
# from which we wish to extract:
#
# chrom start end tf motif
# 1 chr3 128483072 128483461 MAZ Hsapiens-HOCOMOCOv10-MAZ_HUMAN.H10MO.A
# 2 chr3 128483072 128483461 SP4 Hsapiens-HOCOMOCOv10-SP4_HUMAN.H10MO.D
# 3 chr3 128483072 128483461 SP2 Hsapiens-HOCOMOCOv10-SP2_HUMAN.H10MO.C
# 4 chr3 128483072 128483461 SP3 Hsapiens-HOCOMOCOv10-SP3_HUMAN.H10MO.B
# 5 chr3 128483072 128483461 SP3 Hsapiens-SwissRegulon-SP3.SwissRegulon
# 6 chr3 128483072 128483461 SP1 Hsapiens-HOCOMOCOv10-SP1_HUMAN.H10MO.C
#
# and we want
# chrom start end name distance motifName
# chr3 128483072 128483461 MAZ Hsapiens-HOCOMOCOv10-MAZ_HUMAN.H10MO.A
#
# regRegions.names <- unlist(lapply(1:nrow(tbl.reg), function(i){
# distance.from.tss <- tbl.reg$distance.from.tss[i]
# region.size <- nchar(tbl.reg$match[i])
# motif.name <- tbl.reg$motifName[i]
# if(distance.from.tss < 0)
# sprintf("%s.fp.downstream.%05d.L%d.%s", targetGene, abs(distance.from.tss), region.size, motif.name)
# else
# sprintf("%s.fp.upstream.%05d.L%d.%s", targetGene, abs(distance.from.tss), region.size, motif.name)
# }))
#
# tbl.reg$regionName <- regRegions.names
# all.nodes <- unique(c(targetGene, tfs, regRegions.names))
# g <- addNode(all.nodes, g)
#
# nodeData(g, targetGene, "type") <- "targetGene"
# nodeData(g, tfs, "type") <- "TF"
# nodeData(g, regRegions.names, "type") <- "regulatoryRegion"
# nodeData(g, all.nodes, "label") <- all.nodes
# nodeData(g, regRegions.names, "label") <- tbl.reg$motifName
# nodeData(g, regRegions.names, "distance") <- tbl.reg$distance
# nodeData(g, regRegions.names, "motif") <- tbl.reg$motifName
#
.standardizeRegulatoryRegionsTable <- function(tbl.reg, targetGene, tss)
{
locs <- lapply(tbl.reg$loc, parseChromLocString)
tbl.rough <- do.call(rbind, lapply(locs, as.data.frame))
tbl.rough$chrom <- as.character(tbl.rough$chrom)
tbl.rough <- cbind(tbl.rough, tbl.reg[, c("motifName", "fp_start", "fp_end", "geneSymbol")])
make.name <- function(tss, start, tf){
distance.from.tss <- tss - start
sprintf("%s:%d:%s", targetGene, distance.from.tss, tf)
}
regulatory.region.names <- unlist(lapply(1:nrow(tbl.reg),
function(i) make.name(tss, tbl.rough$fp_start[i], tbl.rough$geneSymbol[i])))
tbl.rough$name <- regulatory.region.names
tbl.rough$distance <- tss - tbl.rough$fp_start
tbl.rough$targetGene <- targetGene
tbl.out <- tbl.rough[, c("chrom", "fp_start", "fp_end", "distance", "name", "targetGene", "geneSymbol", "motifName")]
colnames(tbl.out) <- c("chrom", "start", "end", "distance", "name", "targetGene", "tf", "motif")
rownames(tbl.out) <- NULL
tbl.out
} # .standardizeRegulatoryRegionsTable
#------------------------------------------------------------------------------------------------------------------------
.geneRegulatoryModelToGraph <- function(targetGene, tss, tbl.model, tbl.reg)
{
xyz <- ".geneRegulatoryModelToGraph"
tbl.model <- .standardizeModelTable(tbl.model)
tbl.reg <- .standardizeRegulatoryRegionsTable(tbl.reg, targetGene, tss)
required.geneModelColumnNames <- c("tf", "pearson", "spearman", "betaLasso", "randomForest")
required.regulatoryRegionsColumnNames <- c("chrom", "start", "end", "distance", "name", "targetGene", "tf", "motif")
stopifnot(all(required.geneModelColumnNames %in% colnames(tbl.model)))
stopifnot(all(required.regulatoryRegionsColumnNames %in% colnames(tbl.reg)))
printf("genes: %d, %d occurences of %d motifs", length(tbl.model$tf), length(tbl.reg$motif),
length(unique(tbl.reg$motif)))
g <- graphNEL(edgemode = "directed")
nodeDataDefaults(g, attr = "type") <- "undefined" # targetGene, tf, footprint
nodeDataDefaults(g, attr = "label") <- "default node label"
nodeDataDefaults(g, attr = "distance") <- 0
nodeDataDefaults(g, attr = "pearson") <- 0
nodeDataDefaults(g, attr = "randomForest") <- 0
nodeDataDefaults(g, attr = "betaLasso") <- 0
nodeDataDefaults(g, attr = "motif") <- ""
nodeDataDefaults(g, attr = "xPos") <- 0
nodeDataDefaults(g, attr = "yPos") <- 0
edgeDataDefaults(g, attr = "edgeType") <- "undefined"
tfs <- tbl.model$tf
all.nodes <- unique(c(targetGene, tfs, tbl.reg$name))
g <- addNode(all.nodes, g)
nodeData(g, targetGene, "type") <- "targetGene"
nodeData(g, tfs, "type") <- "TF"
nodeData(g, tbl.reg$name, "type") <- "regulatoryRegion"
nodeData(g, all.nodes, "label") <- all.nodes
xyz <- "NetworkView assiging graph node data"
nodeData(g, tbl.reg$name, "label") <- tbl.reg$motif
nodeData(g, tbl.reg$name, "distance") <- tbl.reg$distance
nodeData(g, tbl.reg$name, "motif") <- tbl.reg$motifName
nodeData(g, tfs, "pearson") <- tbl.model$pearson
nodeData(g, tfs, "betaLasso") <- tbl.model$betaLasso
nodeData(g, tfs, "randomForest") <- tbl.model$randomForest
g <- addEdge(tbl.reg$tf, tbl.reg$name, g)
edgeData(g, tbl.reg$tf, tbl.reg$name, "edgeType") <- "bindsTo"
g <- graph::addEdge(tbl.reg$name, targetGene, g)
edgeData(g, tbl.reg$name, targetGene, "edgeType") <- "regulatorySiteFor"
g
} # .geneRegulatoryModelToGraph
#------------------------------------------------------------------------------------------------------------------------
.addGeneModelLayout <- function(g, xPos.span=1500)
{
all.distances <- sort(unique(unlist(nodeData(g, attr='distance'), use.names=FALSE)))
print(all.distances)
fp.nodes <- nodes(g)[which(unlist(nodeData(g, attr="type"), use.names=FALSE) == "regulatoryRegion")]
tf.nodes <- nodes(g)[which(unlist(nodeData(g, attr="type"), use.names=FALSE) == "TF")]
targetGene.nodes <- nodes(g)[which(unlist(nodeData(g, attr="type"), use.names=FALSE) == "targetGene")]
# add in a zero in case all of the footprints are up or downstream of the 0 coordinate, the TSS
span.endpoints <- range(c(0, as.numeric(nodeData(g, fp.nodes, attr="distance"))))
span <- max(span.endpoints) - min(span.endpoints)
footprintLayoutFactor <- 1
printf("initial: span: %d footprintLayoutFactor: %f", span, footprintLayoutFactor)
footprintLayoutFactor <- xPos.span/span
#if(span < 600) #
# footprintLayoutFactor <- 600/span
#if(span > 1000)
# footprintLayoutFactor <- span/1000
printf("corrected: span: %d footprintLayoutFactor: %f", span, footprintLayoutFactor)
xPos <- as.numeric(nodeData(g, fp.nodes, attr="distance")) * footprintLayoutFactor
yPos <- 0
nodeData(g, fp.nodes, "xPos") <- xPos
nodeData(g, fp.nodes, "yPos") <- yPos
adjusted.span.endpoints <- range(c(0, as.numeric(nodeData(g, fp.nodes, attr="xPos"))))
printf("raw span of footprints: %d footprintLayoutFactor: %f new span: %8.0f",
span, footprintLayoutFactor, abs(max(adjusted.span.endpoints) - min(adjusted.span.endpoints)))
tfs <- names(which(nodeData(g, attr="type") == "TF"))
for(tf in tfs){
footprint.neighbors <- edges(g)[[tf]]
if(length(footprint.neighbors) > 0){
footprint.positions <- as.integer(nodeData(g, footprint.neighbors, attr="xPos"))
new.xPos <- mean(footprint.positions)
if(is.na(new.xPos)) browser()
if(is.nan(new.xPos)) browser()
#printf("%8s: %5d", tf, new.xPos)
}
else{
new.xPos <- 0
}
nodeData(g, tf, "yPos") <- sample(300:1200, 1)
nodeData(g, tf, "xPos") <- new.xPos
} # for tf
nodeData(g, targetGene.nodes, "xPos") <- 0
nodeData(g, targetGene.nodes, "yPos") <- -200
g
} # .addGeneModelLayout
#------------------------------------------------------------------------------------------------------------------------
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.