Nothing
R/xGraphML2AA.r
In XGR: Exploring Genomic Relations for Enhanced Interpretation Through Enrichment, Similarity, Network and Annotation Analysis
Defines functions
xGraphML2AA
Documented in
xGraphML2AA
#' Function to generate a graphml file from a pathway upon query
#'
#' \code{xGraphML2AA} is supposed to generate a graphml file from a pathway upon query. If data is provided, pathway gene members are color-coded.
#'
#' @param data a data frame
#' @param org a character specifying an organism. Currently supported organisms are 'human' and 'mouse'
#' @param query the identity of a pathway in query. The full list of pathways can be found at \url{http://www.genome.jp/kegg-bin/show_organism?menu_type=pathway_maps&org=hsa} for human and at \url{http://www.genome.jp/kegg-bin/show_organism?menu_type=pathway_maps&org=mmu} for mouse. For example, 'AA:hsa04672' for 'NOD-like receptor signaling pathway', where the prefix 'AA:' can be ignored. Alternatively, it can be key words describing the pathway
#' @param curation the type of curation. It can be one of "manual" (the manual one 'AA' followed by the semi-manual one 'AT'), "automatic" (only the automatic one) or "any" (first the manual one then the automatic one)
#' @param node.label a character specifying which column used for node labelling. By default, it is 'label'
#' @param node.color a character specifying which column used for node coloring. By default, it is 'lfc'
#' @param colormap short name for the colormap. It can be one of "jet" (jet colormap), "bwr" (blue-white-red colormap), "gbr" (green-black-red colormap), "wyr" (white-yellow-red colormap), "br" (black-red colormap), "yr" (yellow-red colormap), "wb" (white-black colormap), "rainbow" (rainbow colormap, that is, red-yellow-green-cyan-blue-magenta), and "ggplot2" (emulating ggplot2 default color palette). Alternatively, any hyphen-separated HTML color names, e.g. "lightyellow-orange" (by default), "blue-black-yellow", "royalblue-white-sandybrown", "darkgreen-white-darkviolet". A list of standard color names can be found in \url{http://html-color-codes.info/color-names}
#' @param ncolors the number of colors specified over the colormap
#' @param nlegend the number of colors specified in the legend. By default, it is 11
#' @param zlim the minimum and maximum z/patttern values for which colors should be plotted, defaulting to the range of the finite values of z. Each of the given colors will be used to color an equispaced interval of this range. The midpoints of the intervals cover the range, so that values just outside the range will be plotted
#' @param legend.title the legend title. By default, it is ''
#' @param title.thispath the appended title for this pathway. By default, it is NULL
#' @param node.tooltip a character specifying which column used for node tooltip. By default, it is 'tooltip'. If not found, it will be 'Symbol-Name-Color'
#' @param node.highlight a character specifying which column used for node highlighting. By default, it is 'fdr'. If so, those highlighted will have bold and larger labels
#' @param node.highlight.cutoff a numeric specifying the cutoff for node highlighting. By default, it is 0.05 meaninght those less than this cutoff will be highlighted
#' @param edge.color a character specifying the edge colors. By default, it is '#00000033'
#' @param edge.width the edge width. By default, it is 1
#' @param color.gene a character specifying the gene node colors. By default, it is '#dddddd'
#' @param color.thispath a character specifying the color for this pathway node. By default, it is '#dddddd'
#' @param color.otherpath a character specifying the color for other pathway nodes. By default, it is '#eeeeee'
#' @param size.gene an integer character specifying the gene label fontsize. By default, it is 10
#' @param size.gene.found an integer character specifying the label fontsize for genes found/matched. By default, it is 11
#' @param size.gene.highlight an integer character specifying the label fontsize for genes highlighted. By default, it is 12
#' @param filename the without-extension part of the name of the output file. By default, it is 'xGraphML2AA'
#' @param verbose logical to indicate whether the messages will be displayed in the screen. By default, it sets to true for display
#' @param RData.location the characters to tell the location of built-in RData files. See \code{\link{xRDataLoader}} for details
#' @param guid a valid (5-character) Global Unique IDentifier for an OSF project. See \code{\link{xRDataLoader}} for details
#' @return
#' invisible (a string storing graphml-formatted content). If the filename is not NULL, a graphml-formatted file is also output.
#' @note none
#' @export
#' @seealso \code{\link{xGraphML2AA}}
#' @include xGraphML2AA.r
#' @examples
#' # Load the XGR package and specify the location of built-in data
#' library(XGR)
#' RData.location <- "http://galahad.well.ox.ac.uk/bigdata/"
#'
#' \dontrun{
#' data(Haploid_regulators)
#' ## IRF1 regulators
#' data <- subset(Haploid_regulators, Phenotype=='IRF1')
#'
#' xGraphML2AA(query="AA:hsa04630", RData.location=RData.location, color.gene='#dde8f1',size.gene=11)
#'
#' ## load GWAS genes
#' GWAS_Gene <- xRDataLoader(RData.customised='GWAS_Gene', RData.location=RData.location)
#' data <- GWAS_Gene %>% filter(Odds_Ratio!='NULL',Disease_ID=='RA') %>% transmute(label=Symbol,lfc=log2(as.numeric(Odds_Ratio)),fdr=Pvalue) %>% group_by(label) %>% summarise(lfc=max(lfc),fdr=min(fdr))
#'
#' ## manual one (the same as curation='any')
#' xGraphML2AA(data, query="AA:hsa04630", curation='manual', node.label="label", node.color="lfc", node.highlight='fdr', node.highlight.cutoff=5e-8, filename='xGraphML2AA', legend.title='log2(Odds ratio)', zlim=c(-1,1), RData.location=RData.location)
#' ## automatic one
#' xGraphML2AA(data, query="AA:hsa04630", curation='automatic', node.label="label", node.color="lfc", node.highlight='fdr', node.highlight.cutoff=5e-8, filename='xGraphML2AA', legend.title='log2(Odds ratio)', zlim=c(-1,1), RData.location=RData.location)
#'
#' ## key words
#' xGraphML2AA(data, query="Asthma", curation='any', node.label="label", node.color="lfc", node.highlight='fdr', node.highlight.cutoff=5e-8, filename='xGraphML2AA', RData.location=RData.location, legend.title='log2(Odds ratio)', zlim=c(-1,1))
#' }
xGraphML2AA <- function(data=NULL, org=c("human","mouse"), query="AA:hsa04672", curation=c('manual','automatic','any'), node.label='label', node.color='lfc', colormap='deepskyblue-lightyellow-darkorange', ncolors=64, nlegend=9, zlim=NULL, legend.title='', title.thispath=NULL, node.tooltip='tooltip', node.highlight='fdr', node.highlight.cutoff=0.05, edge.color="#00000033", edge.width=1, color.gene='#dddddd', color.thispath='#dddddd', color.otherpath='#eeeeee', size.gene=10, size.gene.found=11, size.gene.highlight=12, filename='xGraphML2AA', verbose=TRUE, RData.location="http://galahad.well.ox.ac.uk/bigdata", guid=NULL)
{
startT <- Sys.time()
if(verbose){
message(paste(c("Start at ",as.character(startT)), collapse=""), appendLF=TRUE)
message("", appendLF=TRUE)
}
####################################################################################
## match.arg matches arg against a table of candidate values as specified by choices, where NULL means to take the first one
curation <- match.arg(curation)
if(any(class(data) %in% c('tbl_df', 'tbl'))){
data <- as.data.frame(data)
}
if(all(c(node.label, node.color) %in% colnames(data))){
df <- data.frame(Symbol=data[,node.label], LFC=signif(data[,node.color],digits=2), stringsAsFactors=FALSE)
}else{
df <- data.frame(Symbol=NA, LFC=0, stringsAsFactors=FALSE)
data <- df
#return(NULL)
}
## FDR (by default, 1)
df$FDR <- rep(1, nrow(df))
if(!is.null(node.highlight)){
if(node.highlight %in% colnames(data)){
df$FDR <- signif(data[,node.highlight],digits=2)
}
}
#################
## make sure numeric values for columns 'LFC' and 'FDR'
df <- df[!is.na(as.numeric(df$LFC)), ]
df <- df[!is.na(as.numeric(df$FDR)), ]
#################
## tooltip
df_res <- xSymbol2GeneID(df$Symbol, org=org, details=TRUE, verbose=verbose, RData.location=RData.location, guid=guid)
df$GeneID <- df_res$GeneID
df$description <- df_res$description
### whether or not FDR is highlighted
if(node.highlight %in% colnames(data)){
df$tooltip <- paste0('Symbol: ', df$Symbol, '\nName: ', df$description, '\nColor: ', df$LFC, '\nHightlight: ', df$FDR)
}else{
df$tooltip <- paste0('Symbol: ', df$Symbol, '\nName: ', df$description, '\nColor: ', df$LFC)
}
if(!is.null(node.tooltip)){
if(node.tooltip %in% colnames(data)){
df$tooltip <- data[,node.tooltip]
}
}
######################################################################################
# df$node.color
######################################################################################
## node.color (by default, "#BFFFBF")
df_legends <- NULL
if (!is.null(node.color)){
ind <- match(node.color, colnames(data))
if(!is.na(ind)){
pattern <- as.numeric(df$LFC)
pattern_nona <- pattern[!is.na(pattern)]
pattern_nona <- as.numeric(pattern_nona)
if(is.null(zlim)){
vmin <- floor(stats::quantile(pattern_nona, 0.05))
vmax <- ceiling(stats::quantile(pattern_nona, 0.95))
if(vmin < 0 & vmax > 0){
vsym <- abs(min(vmin, vmax))
vmin <- -1*vsym
vmax <- vsym
}
zlim <- c(vmin,vmax)
}
## A function to map a vector to colors
vec2color <- function(vec, colormap=colormap, ncolors=ncolors, zlim=zlim){
palette.name <- xColormap(colormap=colormap)
colors <- palette.name(ncolors)
if(max(zlim) != min(zlim)){
scale <- length(colors)/(max(zlim)-min(zlim))
sapply(1:length(vec), function(x){
if(is.na(vec[x])){
'transparent'
}else{
ind <- floor(1+(vec[x]-min(zlim))*scale)
colors[max(1,min(ncolors,ind))]
}
})
}else{
colors[rep(ncolors, length(vec))]
}
}
node.color <- vec2color(pattern, colormap=colormap, ncolors=ncolors, zlim=zlim)
#############
if(length(unique(node.color)) > 1){
## df_legends
colors <- xColormap(colormap=colormap)(ncolors)
legend_colors <- colors[round(seq(1,ncolors,length.out=nlegend))]
df_legends <- data.frame(name=paste0('Legend',(nlegend-1):0), colors=legend_colors, labels=signif(seq(min(zlim),max(zlim),length.out=nlegend),digits=2), stringsAsFactors=FALSE)
}
#############
}else{
#warning("The input 'pattern' is ignored. Please check the help for enabling your input")
node.color <- rep("#BFFFBF", nrow(data))
}
}else{
node.color <- rep("#BFFFBF", nrow(data))
}
df$node.color <- node.color
######################################################################################
######################################################################################
#####################################
manual_ind <- NULL
manual_ind_at <- NULL
if(curation %in% c('any','manual')){
AA.template <- xRDataLoader("AA.template", verbose=verbose, RData.location=RData.location, guid=guid)
info <- AA.template$info
path <- gsub('^AA:', '', info$id)
query <- gsub('^AA:', '', query)
query <- gsub('^path:', '', query)
manual_ind <- match(query, path)
if(is.na(manual_ind)){
manual_ind <- grep(query, info$name)
if(length(manual_ind)>1){
warning(sprintf("Manual curation: %d found for queried %s: only 1st kept", length(manual_ind), query), appendLF=TRUE)
manual_ind <- manual_ind[1]
}else if(length(manual_ind)==0){
warning(sprintf("Manual curation: no found for queried '%s'", query), appendLF=TRUE)
###########################################################
AT.path <- xRDataLoader("AT.path", verbose=verbose, RData.location=RData.location, guid=guid)
info <- AT.path$info
path <- gsub('^AT:', '', info$id)
query <- gsub('^AT:', '', query)
query <- gsub('^path:', '', query)
manual_ind_at <- match(query, path)
if(is.na(manual_ind_at)){
manual_ind_at <- grep(query, info$name)
if(length(manual_ind_at)>1){
warning(sprintf("Automatic curation: %d found for queried %s: only 1st kept", length(manual_ind_at), query), appendLF=TRUE)
manual_ind_at <- manual_ind_at[1]
}else if(length(manual_ind_at)==0){
warning(sprintf("Automatic curation: no found for queried '%s'", query), appendLF=TRUE)
if(curation=='manual'){
return(NULL)
}
}
}
###########################################################
}
}
}
#####################################
if(length(manual_ind) != 0 | length(manual_ind_at) != 0){
if(length(manual_ind) != 0){
if(verbose){
now <- Sys.time()
message(sprintf("Manual curation: visualising '%s: %s' (%s) ...", AA.template$info$id[manual_ind], AA.template$info$name[manual_ind], as.character(now)), appendLF=TRUE)
}
detail <- AA.template$detail[[manual_ind]]
df_nodes <- detail$nodes
df_edges <- detail$edges
}else{
if(verbose){
now <- Sys.time()
message(sprintf("Automatic curation: visualising '%s: %s' (%s) ...", AT.path$info$id[manual_ind_at], AT.path$info$name[manual_ind_at], as.character(now)), appendLF=TRUE)
}
detail <- AT.path$detail[[manual_ind_at]]
df_nodes <- detail$nodes
#########
# remove ::.* for the semi-manual only
#########
df_nodes$node_id <- gsub('::.*','',df_nodes$node_id)
#########
df_edges <- detail$edges
df_edges$source <- gsub('::.*','',df_edges$source)
df_edges$target <- gsub('::.*','',df_edges$target)
}
#############
#############
# convert to mouse genes for df_nodes$name
if(org[1]=="mouse"){
Human2Mouse <- xRDataLoader("Human2Mouse", RData.location=RData.location, guid=guid)
ind <- match(df_nodes$name, Human2Mouse$Human)
df_nodes$name[!is.na(ind)] <- Human2Mouse$Mouse[ind[!is.na(ind)]]
}
#############
#############
#############
## head
#############
output.head <- '<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<graphml xmlns="http://graphml.graphdrawing.org/xmlns" xmlns:java="http://www.yworks.com/xml/yfiles-common/1.0/java" xmlns:sys="http://www.yworks.com/xml/yfiles-common/markup/primitives/2.0" xmlns:x="http://www.yworks.com/xml/yfiles-common/markup/2.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:y="http://www.yworks.com/xml/graphml" xmlns:yed="http://www.yworks.com/xml/yed/3" xsi:schemaLocation="http://graphml.graphdrawing.org/xmlns http://www.yworks.com/xml/schema/graphml/1.1/ygraphml.xsd">
<!--Created by yEd 3.17-->
<key for="node" id="d1" attr.name="url" attr.type="string"/>
<key for="node" id="d2" attr.name="description" attr.type="string"/>
<key for="node" id="d3" yfiles.type="nodegraphics"/>
<key for="edge" id="d4" attr.name="description" attr.type="string"/>
<key for="edge" id="d5" yfiles.type="edgegraphics"/>
<key for="graphml" id="d6" yfiles.type="resources"/>
<graph edgedefault="directed" id="G">'
#############
## nodes
#############
n_total <- 0
n_matched <- 0
for( i in 1:nrow(df_nodes)){
########################
if(grepl('Legend',df_nodes$name[i])){
if(is.null(df_legends)){
next
}
}
########################
ind_found <- match(df_nodes$name[i], df$Symbol)
ind_legend <- match(df_nodes$name[i], df_legends$name)
#############
# gene node
flag_gene <- grepl('#BFFFBF', df_nodes$fill[i])
# this pathway node
flag_thispath <- grepl('#00FF00', df_nodes$fill[i])
# other pathway node
flag_otherpath <- grepl('#C0C0C0', df_nodes$fill[i])
#############
if(flag_gene & is.na(ind_legend)){
n_total <- n_total+1;
if(!is.na(ind_found)){
n_matched <- n_matched+1;
}
}
}
if(verbose){
now <- Sys.time()
message(sprintf("\t %d genes in total and %d genes matched (%s)", n_total, n_matched, as.character(now)), appendLF=TRUE)
}
############
ls_nodes <- lapply(1:nrow(df_nodes), function(i){
########################
if(grepl('Legend',df_nodes$name[i])){
if(is.null(df_legends)){
return(NULL)
}
}
########################
ind_found <- match(df_nodes$name[i], df$Symbol)
ind_legend <- match(df_nodes$name[i], df_legends$name)
#############
# gene node
flag_gene <- grepl('#BFFFBF', df_nodes$fill[i])
# this pathway node
flag_thispath <- grepl('#00FF00', df_nodes$fill[i])
# other pathway node
flag_otherpath <- grepl('#C0C0C0', df_nodes$fill[i])
#############
k <- 0
vec <- vector()
##############
## node id
##############
k <- k+1
vec[k] <- paste0('<node id="', df_nodes$node_id[i], '">')
##############
## data key="d1"
## data key="d2"
##############
if(!is.na(ind_found)){
k <- k+1
#vec[k] <- paste0('<data key="d1"><![CDATA[', "http://www.genecards.org/cgi-bin/carddisp.pl?gene=", df$Symbol[ind_found], ']]></data>')
vec[k] <- paste0('<data key="d1"><![CDATA[', "https://www.ncbi.nlm.nih.gov/gene/", df$GeneID[ind_found], ']]></data>')
k <- k+1
vec[k] <- paste0('<data key="d2"><![CDATA[', df$tooltip[ind_found], ']]></data>')
}else{
if(!is.na(ind_legend)){
k <- k+1
vec[k] <- paste0('<data key="d2"><![CDATA[', df_legends$labels[ind_legend], ']]></data>')
}else{
if(grepl('Legend', df_nodes$name[i])){
return(NULL)
}else if(flag_gene){
k <- k+1
## those not found given the input data, thus only by gene symbols
vec[k] <- paste0('<data key="d1"><![CDATA[', "http://www.genecards.org/cgi-bin/carddisp.pl?gene=", df_nodes$name[i], ']]></data>')
k <- k+1
vec[k] <- paste0('<data key="d2"><![CDATA[', df_nodes$name[i], ']]></data>')
}
}
}
##############
## data key="d3"
##############
k <- k+1
vec[k] <- paste0('<data key="d3">')
##############
## y:ShapeNode
##############
k <- k+1
vec[k] <- paste0('<y:ShapeNode>')
##############
## y:Geometry
##############
k <- k+1
vec[k] <- paste0('<y:Geometry ', df_nodes$geometry[i], '/>')
##############
## y:Fill
##############
fill <- df_nodes$fill[i]
if(!is.na(ind_found)){
fill <- gsub('#BFFFBF', df$node.color[ind_found], fill)
}else{
if(!is.na(ind_legend)){
fill <- gsub('#BFFFBF', df_legends$colors[ind_legend], fill)
}else{
# gene node
fill <- gsub('#BFFFBF', color.gene, fill)
# this pathway node
fill <- gsub('#00FF00', color.thispath, fill)
# other pathway node
fill <- gsub('#C0C0C0', color.otherpath, fill)
}
}
k <- k+1
vec[k] <- paste0('<y:Fill ', fill, '/>')
##############
## y:BorderStyle
##############
borderstyle <- df_nodes$borderstyle[i]
if(!is.na(ind_legend)){
borderstyle <- gsub('color="#\\w+"', 'color="#cccccc"', borderstyle)
borderstyle <- gsub('width=".*"', 'width="0.8"', borderstyle)
}
if(!is.na(ind_found)){
borderstyle <- gsub('color="#\\w+"', 'color="#ffffff00"', borderstyle)
borderstyle <- gsub('width=".*"', 'width="0"', borderstyle)
}else if(flag_gene){
borderstyle <- gsub('color="#\\w+"', 'color="#ffffff00"', borderstyle)
borderstyle <- gsub('width=".*"', 'width="0"', borderstyle)
}
k <- k+1
vec[k] <- paste0('<y:BorderStyle ', borderstyle, '/>')
#alignment="center" autoSizePolicy="content" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="20.48828125" horizontalTextPosition="center" iconTextGap="0" modelName="internal" modelPosition="tl" textColor="#000000" verticalTextPosition="bottom" visible="true" width="98.2265625" x="4.0" y="4.0"
##############
## y:NodeLabel
##############
### nodelabel
nodelabel <- df_nodes$nodelabel[i]
nodelabel <- gsub('fontFamily="\\w+"', 'fontFamily="Arial"', nodelabel)
if(!is.na(ind_found)){
if(df$FDR[ind_found] < node.highlight.cutoff){
## found gene nodes highlighted
nodelabel <- gsub('fontStyle="\\w+"', 'fontStyle="bolditalic"', nodelabel)
#nodelabel <- gsub('fontSize="\\w+"', 'fontSize="12"', nodelabel)
tmp <- paste0('fontSize="', size.gene.highlight, '"')
nodelabel <- gsub('fontSize="\\w+"', tmp, nodelabel)
#nodelabel <- gsub('verticalTextPosition=', 'underlinedText="true" verticalTextPosition=', nodelabel)
}else{
## found gene nodes not highlighted
nodelabel <- gsub('fontStyle="\\w+"', 'fontStyle="italic"', nodelabel)
#nodelabel <- gsub('fontSize="\\w+"', 'fontSize="11"', nodelabel)
tmp <- paste0('fontSize="', size.gene.found, '"')
nodelabel <- gsub('fontSize="\\w+"', tmp, nodelabel)
}
}else if(flag_gene & is.na(ind_legend)){
## gene nodes but not found
nodelabel <- gsub('fontStyle="\\w+"', 'fontStyle="italic"', nodelabel)
#nodelabel <- gsub('fontSize="\\w+"', 'fontSize="10"', nodelabel)
tmp <- paste0('fontSize="', size.gene, '"')
nodelabel <- gsub('fontSize="\\w+"', tmp, nodelabel)
}
### name_display
name_display <- df_nodes$name[i]
name_display <- gsub('@@', '\n', name_display)
if(flag_thispath){
if(!is.null(title.thispath)){
name_display <- paste0(name_display, ' ', title.thispath)
}else{
name_display <- paste0(name_display, ' (AA)')
}
}
if(!is.na(ind_legend)){
name_display <- df_legends$labels[ind_legend]
}else{
if(name_display %in% c("Pi rating", "5-star\nrating")){
name_display <- legend.title
nodelabel <- gsub('modelPosition="\\w+"', 'modelPosition="t"', nodelabel)
}
}
k <- k+1
vec[k] <- paste0('<y:NodeLabel ', nodelabel, '>', name_display, '</y:NodeLabel>')
##############
## y:Shape
##############
k <- k+1
vec[k] <- paste0('<y:Shape ', df_nodes$shape[i], '/>')
k <- k+1
vec[k] <- paste0('</y:ShapeNode>')
k <- k+1
vec[k] <- paste0('</data>')
k <- k+1
vec[k] <- paste0('</node>')
paste(vec, collapse='\n')
})
vec_nodes <- unlist(ls_nodes)
output.nodes <- paste(vec_nodes, collapse='\n')
############
## edges
#############
ls_edges <- lapply(1:nrow(df_edges), function(i){
k <- 0
vec <- vector()
k <- k+1
vec[k] <- paste0('<edge id="', df_edges$edge_id[i], '" source="', df_edges$source[i], '" target="', df_edges$target[i], '">')
k <- k+1
vec[k] <- paste0('<data key="d5">')
k <- k+1
vec[k] <- paste0('<y:GenericEdge configuration="DEFAULT">')
k <- k+1
vec[k] <- paste0('<y:Path ', df_edges$path[i], '/>')
linestyle <- df_edges$linestyle[i]
linestyle <- gsub('#000000', '#888888', linestyle)
k <- k+1
vec[k] <- paste0('<y:LineStyle ', linestyle, '/>')
k <- k+1
vec[k] <- paste0('<y:Arrows ', df_edges$arrows[i], '/>')
k <- k+1
vec[k] <- paste0('</y:GenericEdge>')
k <- k+1
vec[k] <- paste0('</data>')
k <- k+1
vec[k] <- paste0('</edge>')
paste(vec, collapse='\n')
})
vec_edges <- unlist(ls_edges)
output.edges <- paste(vec_edges, collapse='\n')
#############
## tail
#############
output.tail <- '</graph>
<data key="d6">
<y:Resources/>
</data>
</graphml>'
output <- paste0(output.head, '\n', output.nodes, '\n', output.edges, '\n', output.tail, '\n')
if(!is.null(filename)){
############################
filename <- gsub('.graphml$', '', filename)
outputfile <- paste0(filename, ".graphml")
fileConn <- base::file(outputfile)
base::writeLines(output, fileConn)
base::close(fileConn)
if(verbose){
message(sprintf("Congratulations! A file '%s' (in the directory %s) has been created!", outputfile, getwd()), appendLF=T)
}
############################
}
}else if(curation %in% c('automatic','any')){
ls_ig <- xRDataLoader("ig.KEGG.list", verbose=verbose, RData.location=RData.location, guid=guid)
kegg <- gsub('^path:', '', sapply(ls_ig,function(x) x$path))
query <- gsub('^AA:', '', query)
query <- gsub('^AT:', '', query)
query <- gsub('^path:', '', query)
automatic_ind <- match(query, kegg)
if(is.na(automatic_ind)){
automatic_ind <- grep(query, names(kegg))
if(length(automatic_ind)==0){
warning(sprintf("Automated: no found for queried '%s'", query), appendLF=TRUE)
return(NULL)
}else if(length(automatic_ind)>1){
warning(sprintf("Automated: %d found for queried %s: only 1st kept", length(automatic_ind), query), appendLF=TRUE)
automatic_ind <- automatic_ind[1]
}
}
if(verbose){
now <- Sys.time()
message(sprintf("Automated: visualising '%s: %s' (%s) ...", kegg[automatic_ind], names(kegg[automatic_ind]), as.character(now)), appendLF=TRUE)
}
ig <- ls_ig[[automatic_ind]]
if(0){
ind <- match(V(ig)$name, df$Symbol)
nodes_query <- V(ig)$name[!is.na(ind)]
## including incoming neighbors
order <- vcount(ig)
order <- 2
neighs.out <- igraph::neighborhood(ig, order=2, nodes=nodes_query, mode="in")
neighbors <- unique(names(unlist(neighs.out)))
#ind <- match(neighbors, df$Symbol)
#neighbors <- neighbors[!is.na(ind)]
subg <- dnet::dNetInduce(ig, nodes_query=neighbors, knn=0, remove.loops=TRUE, largest.comp=FALSE)
}else{
subg <- ig
}
if(verbose){
now <- Sys.time()
message(sprintf("\t %d genes and %d edges (%s)", vcount(subg), ecount(subg), as.character(now)), appendLF=TRUE)
}
## calling xGraphML
glayout <- igraph::layout_with_kk(subg)
V(subg)$xcoord <- glayout[,1]
V(subg)$ycoord <- glayout[,2]
ind <- match(V(subg)$name, df$Symbol)
V(subg)$LFC <- df$LFC[ind]
V(subg)$tooltip <- df$tooltip[ind]
V(subg)$tooltip[is.na(V(subg)$tooltip)] <- V(subg)$description[is.na(V(subg)$tooltip)]
V(subg)$FDR <- df$FDR[ind]
V(subg)$node.size <- ifelse(V(subg)$FDR<node.highlight.cutoff & !is.na(V(subg)$FDR), 25, 15)
output <- xGraphML(g=subg, node.label="name", node.label.size=10, node.tooltip="tooltip", node.xcoord="xcoord", node.ycoord="ycoord", node.color.na=color.gene, node.color="LFC", node.link="http://www.genecards.org/cgi-bin/carddisp.pl?gene=", nlegend=nlegend, node.size='node.size', node.coord.scale=300, zlim=zlim, colormap=colormap, filename=filename)
#######################################################
}
####################################################################################
endT <- Sys.time()
runTime <- as.numeric(difftime(strptime(endT, "%Y-%m-%d %H:%M:%S"), strptime(startT, "%Y-%m-%d %H:%M:%S"), units="secs"))
if(verbose){
message(paste(c("\nEnd at ",as.character(endT)), collapse=""), appendLF=TRUE)
message(paste(c("Runtime in total is: ",runTime," secs\n"), collapse=""), appendLF=TRUE)
}
invisible(output)
}
Try the XGR package in your browser
Any scripts or data that you put into this service are public.
XGR documentation built on Jan. 8, 2020, 5:06 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 xGraphML2AA
Documented in xGraphML2AA
#' Function to generate a graphml file from a pathway upon query
#'
#' \code{xGraphML2AA} is supposed to generate a graphml file from a pathway upon query. If data is provided, pathway gene members are color-coded.
#'
#' @param data a data frame
#' @param org a character specifying an organism. Currently supported organisms are 'human' and 'mouse'
#' @param query the identity of a pathway in query. The full list of pathways can be found at \url{http://www.genome.jp/kegg-bin/show_organism?menu_type=pathway_maps&org=hsa} for human and at \url{http://www.genome.jp/kegg-bin/show_organism?menu_type=pathway_maps&org=mmu} for mouse. For example, 'AA:hsa04672' for 'NOD-like receptor signaling pathway', where the prefix 'AA:' can be ignored. Alternatively, it can be key words describing the pathway
#' @param curation the type of curation. It can be one of "manual" (the manual one 'AA' followed by the semi-manual one 'AT'), "automatic" (only the automatic one) or "any" (first the manual one then the automatic one)
#' @param node.label a character specifying which column used for node labelling. By default, it is 'label'
#' @param node.color a character specifying which column used for node coloring. By default, it is 'lfc'
#' @param colormap short name for the colormap. It can be one of "jet" (jet colormap), "bwr" (blue-white-red colormap), "gbr" (green-black-red colormap), "wyr" (white-yellow-red colormap), "br" (black-red colormap), "yr" (yellow-red colormap), "wb" (white-black colormap), "rainbow" (rainbow colormap, that is, red-yellow-green-cyan-blue-magenta), and "ggplot2" (emulating ggplot2 default color palette). Alternatively, any hyphen-separated HTML color names, e.g. "lightyellow-orange" (by default), "blue-black-yellow", "royalblue-white-sandybrown", "darkgreen-white-darkviolet". A list of standard color names can be found in \url{http://html-color-codes.info/color-names}
#' @param ncolors the number of colors specified over the colormap
#' @param nlegend the number of colors specified in the legend. By default, it is 11
#' @param zlim the minimum and maximum z/patttern values for which colors should be plotted, defaulting to the range of the finite values of z. Each of the given colors will be used to color an equispaced interval of this range. The midpoints of the intervals cover the range, so that values just outside the range will be plotted
#' @param legend.title the legend title. By default, it is ''
#' @param title.thispath the appended title for this pathway. By default, it is NULL
#' @param node.tooltip a character specifying which column used for node tooltip. By default, it is 'tooltip'. If not found, it will be 'Symbol-Name-Color'
#' @param node.highlight a character specifying which column used for node highlighting. By default, it is 'fdr'. If so, those highlighted will have bold and larger labels
#' @param node.highlight.cutoff a numeric specifying the cutoff for node highlighting. By default, it is 0.05 meaninght those less than this cutoff will be highlighted
#' @param edge.color a character specifying the edge colors. By default, it is '#00000033'
#' @param edge.width the edge width. By default, it is 1
#' @param color.gene a character specifying the gene node colors. By default, it is '#dddddd'
#' @param color.thispath a character specifying the color for this pathway node. By default, it is '#dddddd'
#' @param color.otherpath a character specifying the color for other pathway nodes. By default, it is '#eeeeee'
#' @param size.gene an integer character specifying the gene label fontsize. By default, it is 10
#' @param size.gene.found an integer character specifying the label fontsize for genes found/matched. By default, it is 11
#' @param size.gene.highlight an integer character specifying the label fontsize for genes highlighted. By default, it is 12
#' @param filename the without-extension part of the name of the output file. By default, it is 'xGraphML2AA'
#' @param verbose logical to indicate whether the messages will be displayed in the screen. By default, it sets to true for display
#' @param RData.location the characters to tell the location of built-in RData files. See \code{\link{xRDataLoader}} for details
#' @param guid a valid (5-character) Global Unique IDentifier for an OSF project. See \code{\link{xRDataLoader}} for details
#' @return
#' invisible (a string storing graphml-formatted content). If the filename is not NULL, a graphml-formatted file is also output.
#' @note none
#' @export
#' @seealso \code{\link{xGraphML2AA}}
#' @include xGraphML2AA.r
#' @examples
#' # Load the XGR package and specify the location of built-in data
#' library(XGR)
#' RData.location <- "http://galahad.well.ox.ac.uk/bigdata/"
#'
#' \dontrun{
#' data(Haploid_regulators)
#' ## IRF1 regulators
#' data <- subset(Haploid_regulators, Phenotype=='IRF1')
#'
#' xGraphML2AA(query="AA:hsa04630", RData.location=RData.location, color.gene='#dde8f1',size.gene=11)
#'
#' ## load GWAS genes
#' GWAS_Gene <- xRDataLoader(RData.customised='GWAS_Gene', RData.location=RData.location)
#' data <- GWAS_Gene %>% filter(Odds_Ratio!='NULL',Disease_ID=='RA') %>% transmute(label=Symbol,lfc=log2(as.numeric(Odds_Ratio)),fdr=Pvalue) %>% group_by(label) %>% summarise(lfc=max(lfc),fdr=min(fdr))
#'
#' ## manual one (the same as curation='any')
#' xGraphML2AA(data, query="AA:hsa04630", curation='manual', node.label="label", node.color="lfc", node.highlight='fdr', node.highlight.cutoff=5e-8, filename='xGraphML2AA', legend.title='log2(Odds ratio)', zlim=c(-1,1), RData.location=RData.location)
#' ## automatic one
#' xGraphML2AA(data, query="AA:hsa04630", curation='automatic', node.label="label", node.color="lfc", node.highlight='fdr', node.highlight.cutoff=5e-8, filename='xGraphML2AA', legend.title='log2(Odds ratio)', zlim=c(-1,1), RData.location=RData.location)
#'
#' ## key words
#' xGraphML2AA(data, query="Asthma", curation='any', node.label="label", node.color="lfc", node.highlight='fdr', node.highlight.cutoff=5e-8, filename='xGraphML2AA', RData.location=RData.location, legend.title='log2(Odds ratio)', zlim=c(-1,1))
#' }
xGraphML2AA <- function(data=NULL, org=c("human","mouse"), query="AA:hsa04672", curation=c('manual','automatic','any'), node.label='label', node.color='lfc', colormap='deepskyblue-lightyellow-darkorange', ncolors=64, nlegend=9, zlim=NULL, legend.title='', title.thispath=NULL, node.tooltip='tooltip', node.highlight='fdr', node.highlight.cutoff=0.05, edge.color="#00000033", edge.width=1, color.gene='#dddddd', color.thispath='#dddddd', color.otherpath='#eeeeee', size.gene=10, size.gene.found=11, size.gene.highlight=12, filename='xGraphML2AA', verbose=TRUE, RData.location="http://galahad.well.ox.ac.uk/bigdata", guid=NULL)
{
startT <- Sys.time()
if(verbose){
message(paste(c("Start at ",as.character(startT)), collapse=""), appendLF=TRUE)
message("", appendLF=TRUE)
}
####################################################################################
## match.arg matches arg against a table of candidate values as specified by choices, where NULL means to take the first one
curation <- match.arg(curation)
if(any(class(data) %in% c('tbl_df', 'tbl'))){
data <- as.data.frame(data)
}
if(all(c(node.label, node.color) %in% colnames(data))){
df <- data.frame(Symbol=data[,node.label], LFC=signif(data[,node.color],digits=2), stringsAsFactors=FALSE)
}else{
df <- data.frame(Symbol=NA, LFC=0, stringsAsFactors=FALSE)
data <- df
#return(NULL)
}
## FDR (by default, 1)
df$FDR <- rep(1, nrow(df))
if(!is.null(node.highlight)){
if(node.highlight %in% colnames(data)){
df$FDR <- signif(data[,node.highlight],digits=2)
}
}
#################
## make sure numeric values for columns 'LFC' and 'FDR'
df <- df[!is.na(as.numeric(df$LFC)), ]
df <- df[!is.na(as.numeric(df$FDR)), ]
#################
## tooltip
df_res <- xSymbol2GeneID(df$Symbol, org=org, details=TRUE, verbose=verbose, RData.location=RData.location, guid=guid)
df$GeneID <- df_res$GeneID
df$description <- df_res$description
### whether or not FDR is highlighted
if(node.highlight %in% colnames(data)){
df$tooltip <- paste0('Symbol: ', df$Symbol, '\nName: ', df$description, '\nColor: ', df$LFC, '\nHightlight: ', df$FDR)
}else{
df$tooltip <- paste0('Symbol: ', df$Symbol, '\nName: ', df$description, '\nColor: ', df$LFC)
}
if(!is.null(node.tooltip)){
if(node.tooltip %in% colnames(data)){
df$tooltip <- data[,node.tooltip]
}
}
######################################################################################
# df$node.color
######################################################################################
## node.color (by default, "#BFFFBF")
df_legends <- NULL
if (!is.null(node.color)){
ind <- match(node.color, colnames(data))
if(!is.na(ind)){
pattern <- as.numeric(df$LFC)
pattern_nona <- pattern[!is.na(pattern)]
pattern_nona <- as.numeric(pattern_nona)
if(is.null(zlim)){
vmin <- floor(stats::quantile(pattern_nona, 0.05))
vmax <- ceiling(stats::quantile(pattern_nona, 0.95))
if(vmin < 0 & vmax > 0){
vsym <- abs(min(vmin, vmax))
vmin <- -1*vsym
vmax <- vsym
}
zlim <- c(vmin,vmax)
}
## A function to map a vector to colors
vec2color <- function(vec, colormap=colormap, ncolors=ncolors, zlim=zlim){
palette.name <- xColormap(colormap=colormap)
colors <- palette.name(ncolors)
if(max(zlim) != min(zlim)){
scale <- length(colors)/(max(zlim)-min(zlim))
sapply(1:length(vec), function(x){
if(is.na(vec[x])){
'transparent'
}else{
ind <- floor(1+(vec[x]-min(zlim))*scale)
colors[max(1,min(ncolors,ind))]
}
})
}else{
colors[rep(ncolors, length(vec))]
}
}
node.color <- vec2color(pattern, colormap=colormap, ncolors=ncolors, zlim=zlim)
#############
if(length(unique(node.color)) > 1){
## df_legends
colors <- xColormap(colormap=colormap)(ncolors)
legend_colors <- colors[round(seq(1,ncolors,length.out=nlegend))]
df_legends <- data.frame(name=paste0('Legend',(nlegend-1):0), colors=legend_colors, labels=signif(seq(min(zlim),max(zlim),length.out=nlegend),digits=2), stringsAsFactors=FALSE)
}
#############
}else{
#warning("The input 'pattern' is ignored. Please check the help for enabling your input")
node.color <- rep("#BFFFBF", nrow(data))
}
}else{
node.color <- rep("#BFFFBF", nrow(data))
}
df$node.color <- node.color
######################################################################################
######################################################################################
#####################################
manual_ind <- NULL
manual_ind_at <- NULL
if(curation %in% c('any','manual')){
AA.template <- xRDataLoader("AA.template", verbose=verbose, RData.location=RData.location, guid=guid)
info <- AA.template$info
path <- gsub('^AA:', '', info$id)
query <- gsub('^AA:', '', query)
query <- gsub('^path:', '', query)
manual_ind <- match(query, path)
if(is.na(manual_ind)){
manual_ind <- grep(query, info$name)
if(length(manual_ind)>1){
warning(sprintf("Manual curation: %d found for queried %s: only 1st kept", length(manual_ind), query), appendLF=TRUE)
manual_ind <- manual_ind[1]
}else if(length(manual_ind)==0){
warning(sprintf("Manual curation: no found for queried '%s'", query), appendLF=TRUE)
###########################################################
AT.path <- xRDataLoader("AT.path", verbose=verbose, RData.location=RData.location, guid=guid)
info <- AT.path$info
path <- gsub('^AT:', '', info$id)
query <- gsub('^AT:', '', query)
query <- gsub('^path:', '', query)
manual_ind_at <- match(query, path)
if(is.na(manual_ind_at)){
manual_ind_at <- grep(query, info$name)
if(length(manual_ind_at)>1){
warning(sprintf("Automatic curation: %d found for queried %s: only 1st kept", length(manual_ind_at), query), appendLF=TRUE)
manual_ind_at <- manual_ind_at[1]
}else if(length(manual_ind_at)==0){
warning(sprintf("Automatic curation: no found for queried '%s'", query), appendLF=TRUE)
if(curation=='manual'){
return(NULL)
}
}
}
###########################################################
}
}
}
#####################################
if(length(manual_ind) != 0 | length(manual_ind_at) != 0){
if(length(manual_ind) != 0){
if(verbose){
now <- Sys.time()
message(sprintf("Manual curation: visualising '%s: %s' (%s) ...", AA.template$info$id[manual_ind], AA.template$info$name[manual_ind], as.character(now)), appendLF=TRUE)
}
detail <- AA.template$detail[[manual_ind]]
df_nodes <- detail$nodes
df_edges <- detail$edges
}else{
if(verbose){
now <- Sys.time()
message(sprintf("Automatic curation: visualising '%s: %s' (%s) ...", AT.path$info$id[manual_ind_at], AT.path$info$name[manual_ind_at], as.character(now)), appendLF=TRUE)
}
detail <- AT.path$detail[[manual_ind_at]]
df_nodes <- detail$nodes
#########
# remove ::.* for the semi-manual only
#########
df_nodes$node_id <- gsub('::.*','',df_nodes$node_id)
#########
df_edges <- detail$edges
df_edges$source <- gsub('::.*','',df_edges$source)
df_edges$target <- gsub('::.*','',df_edges$target)
}
#############
#############
# convert to mouse genes for df_nodes$name
if(org[1]=="mouse"){
Human2Mouse <- xRDataLoader("Human2Mouse", RData.location=RData.location, guid=guid)
ind <- match(df_nodes$name, Human2Mouse$Human)
df_nodes$name[!is.na(ind)] <- Human2Mouse$Mouse[ind[!is.na(ind)]]
}
#############
#############
#############
## head
#############
output.head <- '<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<graphml xmlns="http://graphml.graphdrawing.org/xmlns" xmlns:java="http://www.yworks.com/xml/yfiles-common/1.0/java" xmlns:sys="http://www.yworks.com/xml/yfiles-common/markup/primitives/2.0" xmlns:x="http://www.yworks.com/xml/yfiles-common/markup/2.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:y="http://www.yworks.com/xml/graphml" xmlns:yed="http://www.yworks.com/xml/yed/3" xsi:schemaLocation="http://graphml.graphdrawing.org/xmlns http://www.yworks.com/xml/schema/graphml/1.1/ygraphml.xsd">
<!--Created by yEd 3.17-->
<key for="node" id="d1" attr.name="url" attr.type="string"/>
<key for="node" id="d2" attr.name="description" attr.type="string"/>
<key for="node" id="d3" yfiles.type="nodegraphics"/>
<key for="edge" id="d4" attr.name="description" attr.type="string"/>
<key for="edge" id="d5" yfiles.type="edgegraphics"/>
<key for="graphml" id="d6" yfiles.type="resources"/>
<graph edgedefault="directed" id="G">'
#############
## nodes
#############
n_total <- 0
n_matched <- 0
for( i in 1:nrow(df_nodes)){
########################
if(grepl('Legend',df_nodes$name[i])){
if(is.null(df_legends)){
next
}
}
########################
ind_found <- match(df_nodes$name[i], df$Symbol)
ind_legend <- match(df_nodes$name[i], df_legends$name)
#############
# gene node
flag_gene <- grepl('#BFFFBF', df_nodes$fill[i])
# this pathway node
flag_thispath <- grepl('#00FF00', df_nodes$fill[i])
# other pathway node
flag_otherpath <- grepl('#C0C0C0', df_nodes$fill[i])
#############
if(flag_gene & is.na(ind_legend)){
n_total <- n_total+1;
if(!is.na(ind_found)){
n_matched <- n_matched+1;
}
}
}
if(verbose){
now <- Sys.time()
message(sprintf("\t %d genes in total and %d genes matched (%s)", n_total, n_matched, as.character(now)), appendLF=TRUE)
}
############
ls_nodes <- lapply(1:nrow(df_nodes), function(i){
########################
if(grepl('Legend',df_nodes$name[i])){
if(is.null(df_legends)){
return(NULL)
}
}
########################
ind_found <- match(df_nodes$name[i], df$Symbol)
ind_legend <- match(df_nodes$name[i], df_legends$name)
#############
# gene node
flag_gene <- grepl('#BFFFBF', df_nodes$fill[i])
# this pathway node
flag_thispath <- grepl('#00FF00', df_nodes$fill[i])
# other pathway node
flag_otherpath <- grepl('#C0C0C0', df_nodes$fill[i])
#############
k <- 0
vec <- vector()
##############
## node id
##############
k <- k+1
vec[k] <- paste0('<node id="', df_nodes$node_id[i], '">')
##############
## data key="d1"
## data key="d2"
##############
if(!is.na(ind_found)){
k <- k+1
#vec[k] <- paste0('<data key="d1"><![CDATA[', "http://www.genecards.org/cgi-bin/carddisp.pl?gene=", df$Symbol[ind_found], ']]></data>')
vec[k] <- paste0('<data key="d1"><![CDATA[', "https://www.ncbi.nlm.nih.gov/gene/", df$GeneID[ind_found], ']]></data>')
k <- k+1
vec[k] <- paste0('<data key="d2"><![CDATA[', df$tooltip[ind_found], ']]></data>')
}else{
if(!is.na(ind_legend)){
k <- k+1
vec[k] <- paste0('<data key="d2"><![CDATA[', df_legends$labels[ind_legend], ']]></data>')
}else{
if(grepl('Legend', df_nodes$name[i])){
return(NULL)
}else if(flag_gene){
k <- k+1
## those not found given the input data, thus only by gene symbols
vec[k] <- paste0('<data key="d1"><![CDATA[', "http://www.genecards.org/cgi-bin/carddisp.pl?gene=", df_nodes$name[i], ']]></data>')
k <- k+1
vec[k] <- paste0('<data key="d2"><![CDATA[', df_nodes$name[i], ']]></data>')
}
}
}
##############
## data key="d3"
##############
k <- k+1
vec[k] <- paste0('<data key="d3">')
##############
## y:ShapeNode
##############
k <- k+1
vec[k] <- paste0('<y:ShapeNode>')
##############
## y:Geometry
##############
k <- k+1
vec[k] <- paste0('<y:Geometry ', df_nodes$geometry[i], '/>')
##############
## y:Fill
##############
fill <- df_nodes$fill[i]
if(!is.na(ind_found)){
fill <- gsub('#BFFFBF', df$node.color[ind_found], fill)
}else{
if(!is.na(ind_legend)){
fill <- gsub('#BFFFBF', df_legends$colors[ind_legend], fill)
}else{
# gene node
fill <- gsub('#BFFFBF', color.gene, fill)
# this pathway node
fill <- gsub('#00FF00', color.thispath, fill)
# other pathway node
fill <- gsub('#C0C0C0', color.otherpath, fill)
}
}
k <- k+1
vec[k] <- paste0('<y:Fill ', fill, '/>')
##############
## y:BorderStyle
##############
borderstyle <- df_nodes$borderstyle[i]
if(!is.na(ind_legend)){
borderstyle <- gsub('color="#\\w+"', 'color="#cccccc"', borderstyle)
borderstyle <- gsub('width=".*"', 'width="0.8"', borderstyle)
}
if(!is.na(ind_found)){
borderstyle <- gsub('color="#\\w+"', 'color="#ffffff00"', borderstyle)
borderstyle <- gsub('width=".*"', 'width="0"', borderstyle)
}else if(flag_gene){
borderstyle <- gsub('color="#\\w+"', 'color="#ffffff00"', borderstyle)
borderstyle <- gsub('width=".*"', 'width="0"', borderstyle)
}
k <- k+1
vec[k] <- paste0('<y:BorderStyle ', borderstyle, '/>')
#alignment="center" autoSizePolicy="content" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="20.48828125" horizontalTextPosition="center" iconTextGap="0" modelName="internal" modelPosition="tl" textColor="#000000" verticalTextPosition="bottom" visible="true" width="98.2265625" x="4.0" y="4.0"
##############
## y:NodeLabel
##############
### nodelabel
nodelabel <- df_nodes$nodelabel[i]
nodelabel <- gsub('fontFamily="\\w+"', 'fontFamily="Arial"', nodelabel)
if(!is.na(ind_found)){
if(df$FDR[ind_found] < node.highlight.cutoff){
## found gene nodes highlighted
nodelabel <- gsub('fontStyle="\\w+"', 'fontStyle="bolditalic"', nodelabel)
#nodelabel <- gsub('fontSize="\\w+"', 'fontSize="12"', nodelabel)
tmp <- paste0('fontSize="', size.gene.highlight, '"')
nodelabel <- gsub('fontSize="\\w+"', tmp, nodelabel)
#nodelabel <- gsub('verticalTextPosition=', 'underlinedText="true" verticalTextPosition=', nodelabel)
}else{
## found gene nodes not highlighted
nodelabel <- gsub('fontStyle="\\w+"', 'fontStyle="italic"', nodelabel)
#nodelabel <- gsub('fontSize="\\w+"', 'fontSize="11"', nodelabel)
tmp <- paste0('fontSize="', size.gene.found, '"')
nodelabel <- gsub('fontSize="\\w+"', tmp, nodelabel)
}
}else if(flag_gene & is.na(ind_legend)){
## gene nodes but not found
nodelabel <- gsub('fontStyle="\\w+"', 'fontStyle="italic"', nodelabel)
#nodelabel <- gsub('fontSize="\\w+"', 'fontSize="10"', nodelabel)
tmp <- paste0('fontSize="', size.gene, '"')
nodelabel <- gsub('fontSize="\\w+"', tmp, nodelabel)
}
### name_display
name_display <- df_nodes$name[i]
name_display <- gsub('@@', '\n', name_display)
if(flag_thispath){
if(!is.null(title.thispath)){
name_display <- paste0(name_display, ' ', title.thispath)
}else{
name_display <- paste0(name_display, ' (AA)')
}
}
if(!is.na(ind_legend)){
name_display <- df_legends$labels[ind_legend]
}else{
if(name_display %in% c("Pi rating", "5-star\nrating")){
name_display <- legend.title
nodelabel <- gsub('modelPosition="\\w+"', 'modelPosition="t"', nodelabel)
}
}
k <- k+1
vec[k] <- paste0('<y:NodeLabel ', nodelabel, '>', name_display, '</y:NodeLabel>')
##############
## y:Shape
##############
k <- k+1
vec[k] <- paste0('<y:Shape ', df_nodes$shape[i], '/>')
k <- k+1
vec[k] <- paste0('</y:ShapeNode>')
k <- k+1
vec[k] <- paste0('</data>')
k <- k+1
vec[k] <- paste0('</node>')
paste(vec, collapse='\n')
})
vec_nodes <- unlist(ls_nodes)
output.nodes <- paste(vec_nodes, collapse='\n')
############
## edges
#############
ls_edges <- lapply(1:nrow(df_edges), function(i){
k <- 0
vec <- vector()
k <- k+1
vec[k] <- paste0('<edge id="', df_edges$edge_id[i], '" source="', df_edges$source[i], '" target="', df_edges$target[i], '">')
k <- k+1
vec[k] <- paste0('<data key="d5">')
k <- k+1
vec[k] <- paste0('<y:GenericEdge configuration="DEFAULT">')
k <- k+1
vec[k] <- paste0('<y:Path ', df_edges$path[i], '/>')
linestyle <- df_edges$linestyle[i]
linestyle <- gsub('#000000', '#888888', linestyle)
k <- k+1
vec[k] <- paste0('<y:LineStyle ', linestyle, '/>')
k <- k+1
vec[k] <- paste0('<y:Arrows ', df_edges$arrows[i], '/>')
k <- k+1
vec[k] <- paste0('</y:GenericEdge>')
k <- k+1
vec[k] <- paste0('</data>')
k <- k+1
vec[k] <- paste0('</edge>')
paste(vec, collapse='\n')
})
vec_edges <- unlist(ls_edges)
output.edges <- paste(vec_edges, collapse='\n')
#############
## tail
#############
output.tail <- '</graph>
<data key="d6">
<y:Resources/>
</data>
</graphml>'
output <- paste0(output.head, '\n', output.nodes, '\n', output.edges, '\n', output.tail, '\n')
if(!is.null(filename)){
############################
filename <- gsub('.graphml$', '', filename)
outputfile <- paste0(filename, ".graphml")
fileConn <- base::file(outputfile)
base::writeLines(output, fileConn)
base::close(fileConn)
if(verbose){
message(sprintf("Congratulations! A file '%s' (in the directory %s) has been created!", outputfile, getwd()), appendLF=T)
}
############################
}
}else if(curation %in% c('automatic','any')){
ls_ig <- xRDataLoader("ig.KEGG.list", verbose=verbose, RData.location=RData.location, guid=guid)
kegg <- gsub('^path:', '', sapply(ls_ig,function(x) x$path))
query <- gsub('^AA:', '', query)
query <- gsub('^AT:', '', query)
query <- gsub('^path:', '', query)
automatic_ind <- match(query, kegg)
if(is.na(automatic_ind)){
automatic_ind <- grep(query, names(kegg))
if(length(automatic_ind)==0){
warning(sprintf("Automated: no found for queried '%s'", query), appendLF=TRUE)
return(NULL)
}else if(length(automatic_ind)>1){
warning(sprintf("Automated: %d found for queried %s: only 1st kept", length(automatic_ind), query), appendLF=TRUE)
automatic_ind <- automatic_ind[1]
}
}
if(verbose){
now <- Sys.time()
message(sprintf("Automated: visualising '%s: %s' (%s) ...", kegg[automatic_ind], names(kegg[automatic_ind]), as.character(now)), appendLF=TRUE)
}
ig <- ls_ig[[automatic_ind]]
if(0){
ind <- match(V(ig)$name, df$Symbol)
nodes_query <- V(ig)$name[!is.na(ind)]
## including incoming neighbors
order <- vcount(ig)
order <- 2
neighs.out <- igraph::neighborhood(ig, order=2, nodes=nodes_query, mode="in")
neighbors <- unique(names(unlist(neighs.out)))
#ind <- match(neighbors, df$Symbol)
#neighbors <- neighbors[!is.na(ind)]
subg <- dnet::dNetInduce(ig, nodes_query=neighbors, knn=0, remove.loops=TRUE, largest.comp=FALSE)
}else{
subg <- ig
}
if(verbose){
now <- Sys.time()
message(sprintf("\t %d genes and %d edges (%s)", vcount(subg), ecount(subg), as.character(now)), appendLF=TRUE)
}
## calling xGraphML
glayout <- igraph::layout_with_kk(subg)
V(subg)$xcoord <- glayout[,1]
V(subg)$ycoord <- glayout[,2]
ind <- match(V(subg)$name, df$Symbol)
V(subg)$LFC <- df$LFC[ind]
V(subg)$tooltip <- df$tooltip[ind]
V(subg)$tooltip[is.na(V(subg)$tooltip)] <- V(subg)$description[is.na(V(subg)$tooltip)]
V(subg)$FDR <- df$FDR[ind]
V(subg)$node.size <- ifelse(V(subg)$FDR<node.highlight.cutoff & !is.na(V(subg)$FDR), 25, 15)
output <- xGraphML(g=subg, node.label="name", node.label.size=10, node.tooltip="tooltip", node.xcoord="xcoord", node.ycoord="ycoord", node.color.na=color.gene, node.color="LFC", node.link="http://www.genecards.org/cgi-bin/carddisp.pl?gene=", nlegend=nlegend, node.size='node.size', node.coord.scale=300, zlim=zlim, colormap=colormap, filename=filename)
#######################################################
}
####################################################################################
endT <- Sys.time()
runTime <- as.numeric(difftime(strptime(endT, "%Y-%m-%d %H:%M:%S"), strptime(startT, "%Y-%m-%d %H:%M:%S"), units="secs"))
if(verbose){
message(paste(c("\nEnd at ",as.character(endT)), collapse=""), appendLF=TRUE)
message(paste(c("Runtime in total is: ",runTime," secs\n"), collapse=""), appendLF=TRUE)
}
invisible(output)
}
Try the XGR package in your browser
Any scripts or data that you put into this service are public.
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.