#' Explore BE identifiers
#'
#' This function uses visNetwork to draw all the identifiers
#' corresponding to one BE (including ProbeID and BESymbol)
#'
#' @param id one ID for the BE
#' @param source the ID source database. **Guessed if not provided**
#' @param be the type of BE. **Guessed if not provided**
#' @param showProbes boolean. If TRUE, probes targeting any BEID are shown.
#' @param showBE boolean. If TRUE the Biological Entity corresponding to the
#' id is shown. If id is isolated (not mapped to any other ID or symbol)
#' BE is shown anyway.
#'
#' @examples \dontrun{
#' exploreBe("Gene", "100", "EntrezGene")
#' }
#'
#' @export
#'
exploreBe <- function(id, source, be, showBE=FALSE, showProbes=FALSE){
id <- as.character(id)
stopifnot(length(id)==1)
##
if(missing(be) || missing(source)){
toWarn <- TRUE
}else{
toWarn <- FALSE
}
guess <- guessIdScope(ids=id, be=be, source=source)
if(is.null(guess)){
stop("Could not find the provided id")
}
if(is.na(guess$be)){
stop(
"The provided id does not match the provided scope",
" (be, source or organism)"
)
}
be <- guess$be
source <- guess$source
organism <- guess$organism
if(toWarn){
warning(
"Guessing ID scope:",
sprintf("\n - be: %s", be),
sprintf("\n - source: %s", source),
sprintf("\n - organism: %s", organism)
)
}
##
if(be=="Probe"){
showProbes <- TRUE
}
netRows1 <- bedCall(
f=neo2R::cypher,
query=neo2R::prepCql(
sprintf(
'MATCH (s:%s {value:$id, %s:$db})',
paste0(be, "ID"),
ifelse(be=="Probe", "platform", "database")
),
'-[:is_replaced_by|is_associated_to|targets*0..]->()',
'-[:identifies]->(be)',
'WITH DISTINCT be',
'MATCH (be)<-[ir:identifies]-(di)',
'RETURN DISTINCT',
'id(ir) as id, type(ir) as type,',
'id(di) as start,',
'id(be) as end'
),
result="row",
parameters=list(id=id, db=source, can=TRUE)
)
if(nrow(netRows1)==0){
stop(sprintf(
'"%s" (id) not found as a "%s" (be) in "%s" database (source).',
id, be, source
))
}
netRows2 <- bedCall(
f=neo2R::cypher,
query=neo2R::prepCql(
'MATCH (di) WHERE id(di) IN $ids',
'MATCH (di)-[cr:corresponds_to]->(di2)',
'RETURN DISTINCT',
'id(cr) as id, type(cr) as type,',
'id(di) as start,',
'id(di2) as end'
),
result="row",
parameters=list(ids=unique(netRows1$start))
)
netRows3 <- bedCall(
f=neo2R::cypher,
query=neo2R::prepCql(
'MATCH (di) WHERE id(di) IN $ids',
'MATCH (di)<-[iir:is_replaced_by|is_associated_to*0..]-(ii)',
'UNWIND iir as iirr',
'MATCH (i1)-[iirr]->(i2)',
'RETURN DISTINCT',
'id(iirr) as id, type(iirr) as type,',
'id(i1) as start,',
'id(i2) as end'
),
result="row",
parameters=list(ids=unique(netRows1$start))
)
netRows4 <- bedCall(
f=neo2R::cypher,
query=neo2R::prepCql(
'MATCH (ai) WHERE id(ai) IN $ids',
'MATCH (ai)-[r:is_known_as {canonical:$can}]->(as:BESymbol)',
'RETURN DISTINCT',
'id(r) as id, type(r) as type,',
'id(ai) as start,',
'id(as) as end'
),
result="row",
parameters=list(
ids=unique(c(
netRows1$start,
netRows2$start, netRows2$end,
netRows3$start, netRows3$end
)),
can=TRUE
)
)
netRows5 <- bedCall(
f=neo2R::cypher,
query=neo2R::prepCql(
'MATCH (ai) WHERE id(ai) IN $ids',
'MATCH (ai)<-[r:targets]-(ap:ProbeID)',
'RETURN DISTINCT',
'id(r) as id, type(r) as type,',
'id(ai) as start,',
'id(ap) as end'
),
result="row",
parameters=list(
ids=unique(c(
netRows1$start,
netRows2$start, netRows2$end,
netRows3$start, netRows3$end
)),
can=TRUE
)
)
edges <- rbind(
netRows1, netRows2, netRows3, netRows4, netRows5
)
nodes <- bedCall(
f=neo2R::cypher,
query=neo2R::prepCql(
'MATCH (n) WHERE id(n) IN $ids',
'RETURN DISTINCT',
'id(n) as id, labels(n) as label,',
'n.value as value, n.database as database, n.platform as platform,',
'n.preferred as preferred'
),
result="row",
parameters=list(ids=unique(c(edges$start, edges$end)))
)
nodes$label <- gsub(" [|][|] ", "", gsub("BEID", "", nodes$label))
nodes$url <- getBeIdURL(
ids=nodes$value,
databases=nodes$database
)
if(!showProbes){
toRm <- nodes$id[which(nodes$label=="ProbeID")]
nodes <- nodes[which(!nodes$id %in% toRm),]
edges <- edges[which(!edges$start %in% toRm & !edges$end %in% toRm),]
}
if(!showBE){
if(nrow(nodes)<=2){
showBE <- TRUE
}else{
toRm <- nodes$id[which(nodes$label==be)]
nodes <- nodes[which(!nodes$id %in% toRm),]
edges <- edges[which(!edges$start %in% toRm & !edges$end %in% toRm),]
}
}
for(cn in colnames(nodes)){
if(is.character(nodes[[cn]])){
nodes[[cn]] <- ifelse(is.na(nodes[[cn]]), "", nodes[[cn]])
}
}
tpNodes <- nodes
colnames(tpNodes) <- c(
"id", "type", "label", "database", "platform", "preferred", "url"
)
tpNodes$source <- paste0(tpNodes$database, tpNodes$platform)
tpNodes$title <- paste0(
'<p>',
'<strong>',
tpNodes$type,
'</strong><br>',
ifelse(
tpNodes$label!="",
ifelse(
tpNodes$url!="",
paste0(
sprintf(
'<a href="%s" target="_blank">',
tpNodes$url
),
tpNodes$label,
'</a>'
),
tpNodes$label
),
""
),
ifelse(
tpNodes$source!="",
paste0(
'<br>',
'<emph>', tpNodes$source, '</emph>'
),
""
),
ifelse(
!is.na(as.logical(tpNodes$preferred)) & as.logical(tpNodes$preferred),
"<br>Preferred",
""
),
'</p>'
)
##
nshapes <- c(
if(showBE){c(be="diamond")}else{c()},
beid="dot",
BESymbol="box"
)
if(showBE){
names(nshapes) <- c(be, paste0(be, "ID"), "BESymbol")
}else{
names(nshapes) <- c(paste0(be, "ID"), "BESymbol")
}
if(showProbes){
nshapes <- c(nshapes, ProbeID="triangle")
}
tpNodes$shape <- nshapes[tpNodes$type]
##
ncolors <- c(
"#E2B845", "#E4AC77", "#67E781", "#E2DBE6", "#7E58DB",
"#B694E4", "#B4E5BC", "#7299E1", "#E56E40", "#62B0DB", "#D46EE2",
"#B2C0E7", "#E4E3C6", "#D8E742", "#D7699E", "#66E5B0", "#E6B7E0",
"#70D1E2", "#6778DF", "#80B652", "#E4E19E", "#E790DE", "#D8E577",
"#6EEADD", "#DA3FE3", "#9F6D5B", "#5EA88C", "#8535E7", "#7EEA49",
"#AB88A7", "#E24869", "#E547B1", "#BBE8E5", "#9DADA8", "#E3B9B0",
"#B1EA9A", "#557083", "#9F9F66", "#874C99", "#E68D97"
)
ncol <- length(unique(tpNodes$source))+2
ncolors <- rep(ncolors, (ncol %/% length(ncolors))+1)
ncolors <- ncolors[1:ncol]
names(ncolors) <- c(be, "BESymbol", unique(tpNodes$source))
tpNodes$color.background <- ifelse(
tpNodes$type==be, ncolors[be],
ifelse(
tpNodes$type=="BESymbol", ncolors["BESymbol"],
ifelse(
tpNodes$source!="",
ncolors[tpNodes$source],
"grey"
)
)
)
tpNodes$borderWidth <- 1
tpNodes[which(as.logical(tpNodes$preferred)),"borderWidth"] <- 4
tpNodes$borderWidthSelected <- 2
tpNodes[which(as.logical(tpNodes$preferred)),"borderWidthSelected"] <- 4
# tpNodes$color.background <- "#BB6ED4"
# tpNodes$color.background[which(tpNodes$type=="BESymbol")] <- "#DB9791"
# tpNodes$color.background[grep("ID", tpNodes$type)] <- "#B1DE79"
# tpNodes$color.background[which(tpNodes$type=="ProbeID")] <- "#A4D0D3"
tpNodes$color.border="black"
tpEdges <- edges
colnames(tpEdges) <- c("id", "title", "from", "to")
tpEdges$arrows <- "to"
tpEdges$dashes <- ifelse(
tpEdges$title %in% c("is_associated_to", "is_replaced_by"),
TRUE,
FALSE
)
toRet <- visNetwork::visNetwork(
nodes=tpNodes,
edges=tpEdges
)
toRet <- visNetwork::visInteraction(graph=toRet, selectable=TRUE)
toRet <- visNetwork::visOptions(
graph=toRet,
highlightNearest = TRUE,
nodesIdSelection=list(
selected=tpNodes$id[which(
tpNodes$label==id & tpNodes$source==source
)]
)
)
toRet <- visNetwork::visLegend(
graph=toRet,
addNodes=c(
lapply(
names(nshapes),
function(x){
return(list(
label=x,
shape=as.character(nshapes[x]),
color=as.character(ncolors[x])
))
}
),
# if(showProbes){
lapply(
setdiff(names(ncolors), c("", be, names(nshapes))),
function(x){
return(list(
label=x, shape="dot", color=as.character(ncolors[x])
))
}
)
# }else{
# list()
# }
),
ncol=ifelse(showProbes, 3, 2),
width=ifelse(showProbes, 0.3, 0.2),
position="left",
useGroups = FALSE
)
return(toRet)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.