#' Information on a GeneOntology identifier
#'
#' Assembles information, in HTML format, regarding a Gene Ontology identifier
#'
#' Also creates a link to the AmiGO database
#'
#' @param go_id Character, specifying the GeneOntology identifier for which
#' to retrieve information
#' @param res_enrich A `data.frame` object, storing the result of the functional
#' enrichment analysis. If not provided, the experiment-related information is not
#' shown, and only some generic info on the identifier is displayed.
#' See more in the main function, [GeneTonic()], to check the
#' formatting requirements (a minimal set of columns should be present).
#'
#' @return HTML content related to a GeneOntology identifier, to be displayed in
#' web applications (or inserted in Rmd documents)
#' @export
#'
#' @examples
#' go_2_html("GO:0002250")
#' go_2_html("GO:0043368")
go_2_html <- function(go_id,
res_enrich = NULL) {
fullinfo <- GOTERM[[go_id]]
if (is.null(fullinfo)) {
return(HTML("Gene Ontology term not found!"))
}
# extracting the field/component values
go_linkbutton <- .link2amigo(GOID(fullinfo))
go_term <- Term(fullinfo)
go_ontology <- Ontology(fullinfo)
go_definition <- Definition(fullinfo)
go_synonims <- paste0(
unlist(
lapply(Synonym(fullinfo), function(arg) {
paste0(tags$b("Synonym: "), arg, tags$br())
})
), collapse = ""
)
go_secondary <- Secondary(fullinfo)
if (!is.null(res_enrich)) {
go_pvalue <- res_enrich[(res_enrich$gs_id == go_id), "gs_pvalue"]
go_zscore <- ifelse(
"z_score" %in% colnames(res_enrich),
format(round(res_enrich[(res_enrich$gs_id == go_id), "z_score"], 2), nsmall = 2),
"NA - not yet computed"
)
go_aggrscore <- ifelse(
"aggr_score" %in% colnames(res_enrich),
format(round(res_enrich[(res_enrich$gs_id == go_id), "aggr_score"], 2), nsmall = 2),
"NA - not yet computed"
)
}
# assembling them together
mycontent <- paste0(
tags$b("GO ID: "), go_linkbutton, tags$br(),
tags$b("Term: "), go_term, tags$br(),
ifelse(
!is.null(res_enrich),
paste0(tags$b("p-value: "), go_pvalue, tags$br(),
tags$b("Z-score: "), go_zscore, tags$br(),
tags$b("Aggregated score: "), go_aggrscore, tags$br(),
collapse = ""),
""
),
tags$b("Ontology: "), go_ontology, tags$br(), tags$br(),
tags$b("Definition: "), go_definition, tags$br(),
go_synonims,
ifelse(
length(go_secondary) > 0,
paste0(tags$b("Secondary: "), go_secondary, collapse = ""),
"")
)
return(HTML(mycontent))
}
#' Link to the AmiGO database
#'
#' @param val A string, with the GO identifier
#'
#' @return HTML for an action button
#' @noRd
.link2amigo <- function(val) {
sprintf('<a href = "http://amigo.geneontology.org/amigo/term/%s" target = "_blank" class = "btn btn-primary" style = "%s">%s</a>',
val,
.actionbutton_biocstyle,
val)
}
#' Information on a gene
#'
#' Assembles information, in HTML format, regarding a gene symbol identifier
#'
#' Creates links to the NCBI and the GeneCards databases
#'
#' @param gene_id Character specifying the gene identifier for which to retrieve
#' information
#' @param res_de A `DESeqResults` object, storing the result of the differential
#' expression analysis. If not provided, the experiment-related information is not
#' shown, and only some generic info on the identifier is displayed.
#' The information about the gene is retrieved by matching on the `SYMBOL` column,
#' which should be provided in `res_de`.
#'
#' @return HTML content related to a gene identifier, to be displayed in
#' web applications (or inserted in Rmd documents)
#' @export
#'
#' @examples
#' geneinfo_2_html("ACTB")
#' geneinfo_2_html("Pf4")
geneinfo_2_html <- function(gene_id,
res_de = NULL) {
gene_ncbi_button <- .link2ncbi(gene_id)
gene_genecards_button <- .link2genecards(gene_id)
gene_gtex_button <- .link2gtex(gene_id)
if (!is.null(res_de)) {
gid <- match(gene_id, res_de$SYMBOL)
if (is.na(gid)) {
message("Could not find the specified gene (`", gene_id,
"`) in the `res_de` object. \n",
"Still, the general HTML content has been generated.")
gene_adjpvalue <- tags$em("not found")
gene_logfc <- tags$em("not found")
} else {
gene_adjpvalue <- format(res_de[gid, "padj"])
gene_logfc <- format(round(res_de[gid, "log2FoldChange"], 2), nsmall = 2)
}
}
mycontent <- paste0(
tags$b(gene_id), tags$br(),
"Link to the NCBI Gene database: ", gene_ncbi_button, tags$br(),
"Link to the GeneCards database: ", gene_genecards_button, tags$br(),
"Link to the GTEx Portal: ", gene_gtex_button, tags$br(),
ifelse(
!is.null(res_de),
paste0(tags$b("DE p-value (adjusted): "), gene_adjpvalue, tags$br(),
tags$b("DE log2FoldChange: "), gene_logfc,
collapse = ""),
""
)
)
return(HTML(mycontent))
}
#' Link to NCBI database
#'
#' @param val Character, the gene symbol
#'
#' @return HTML for an action button
#' @noRd
.link2ncbi <- function(val) {
sprintf('<a href = "http://www.ncbi.nlm.nih.gov/gene/?term=%s[sym]" target = "_blank" class = "btn btn-primary" style = "%s">%s</a>',
val,
.actionbutton_biocstyle,
val)
}
#' Link to the GeneCards database
#'
#' @param val Character, the gene symbol of interest
#'
#' @return HTML for an action button
#' @noRd
.link2genecards <- function(val) {
sprintf('<a href = "https://www.genecards.org/cgi-bin/carddisp.pl?gene=%s" target = "_blank" class = "btn btn-primary" style = "%s">%s</a>',
val,
.actionbutton_biocstyle,
val)
}
#' Link to the GTEx Portal
#'
#' @param val Character, the gene symbol of interest
#'
#' @return HTML for an action button
#' @noRd
.link2gtex <- function(val) {
sprintf('<a href = "https://www.gtexportal.org/home/gene/%s" target = "_blank" class = "btn btn-primary" style = "%s"><i class="fa fa-dna"></i>%s</a>',
val,
.actionbutton_biocstyle,
val)
}
#' Calculate overlap coefficient
#'
#' Calculate similarity coefficient between two sets, based on the overlap
#'
#' @param x Character vector, corresponding to set 1
#' @param y Character vector, set 2
#'
#' @return A numeric value between 0 and 1
#' @export
#'
#' @seealso https://en.wikipedia.org/wiki/Overlap_coefficient
#'
#' @examples
#' a <- seq(1, 21, 2)
#' b <- seq(1, 11, 2)
#' overlap_coefficient(a,b)
overlap_coefficient <- function(x, y) {
length(intersect(x, y)) / min(length(x), length(y))
}
#' Calculate Jaccard Index between two sets
#'
#' Calculate similarity coefficient with the Jaccard Index
#'
#' @param x Character vector, corresponding to set 1
#' @param y Character vector, corresponding to set 2
#'
#' @return A numeric value between 0 and 1
#' @export
#'
#' @examples
#' a <- seq(1, 21, 2)
#' b <- seq(1, 11, 2)
#' overlap_jaccard_index(a,b)
overlap_jaccard_index <- function(x, y) {
length(intersect(x, y)) / length(unique(c(x, y)))
# about 2x faster than using union()
}
#' Style DT color bars
#'
#' Style DT color bars for values that diverge from 0.
#'
#' @details This function draws background color bars behind table cells in a column,
#' width the width of bars being proportional to the column values *and* the color
#' dependent on the sign of the value.
#'
#' A typical usage is for values such as `log2FoldChange` for tables resulting from
#' differential expression analysis.
#' Still, the functionality of this can be quickly generalized to other cases -
#' see in the examples.
#'
#' The code of this function is heavily inspired from styleColorBar, and borrows
#' at full hands from an excellent post on StackOverflow -
#' https://stackoverflow.com/questions/33521828/stylecolorbar-center-and-shift-left-right-dependent-on-sign/33524422#33524422
#'
#' @param data The numeric vector whose range will be used for scaling the table
#' data from 0-100 before being represented as color bars. A vector of length 2
#' is acceptable here for specifying a range possibly wider or narrower than the
#' range of the table data itself.
#' @param color_pos The color of the bars for the positive values
#' @param color_neg The color of the bars for the negative values
#'
#' @return This function generates JavaScript and CSS code from the values
#' specified in R, to be used in DT tables formatting.
#'
#' @export
#'
#' @examples
#'
#' data(res_de_macrophage, package = "GeneTonic")
#' res_df <- deseqresult2df(res_macrophage_IFNg_vs_naive)
#' library("magrittr")
#' library("DT")
#' DT::datatable(res_df [1:50, ],
#' options = list(
#' pageLength = 25,
#' columnDefs = list(
#' list(className = "dt-center", targets = "_all")
#' )
#' )
#' ) %>%
#' formatRound(columns = c("log2FoldChange"), digits = 3) %>%
#' formatStyle(
#' "log2FoldChange",
#' background = styleColorBar_divergent(res_df$log2FoldChange,
#' scales::alpha("navyblue", 0.4),
#' scales::alpha("darkred", 0.4)),
#' backgroundSize = "100% 90%",
#' backgroundRepeat = "no-repeat",
#' backgroundPosition = "center"
#' )
#'
#'
#' simplest_df <- data.frame(
#' a = c(rep("a",9)),
#' value = c(-4, -3, -2, -1, 0, 1, 2, 3, 4)
#' )
#'
#' # or with a very simple data frame
#' DT::datatable(simplest_df) %>%
#' formatStyle(
#' 'value',
#' background = styleColorBar_divergent(simplest_df$value,
#' scales::alpha("forestgreen", 0.4),
#' scales::alpha("gold", 0.4)),
#' backgroundSize = "100% 90%",
#' backgroundRepeat = "no-repeat",
#' backgroundPosition = "center"
#' )
styleColorBar_divergent <- function(data,
color_pos,
color_neg) {
max_val <- max(abs(data))
JS(
sprintf(
"isNaN(parseFloat(value)) || value < 0 ? 'linear-gradient(90deg, transparent, transparent ' + (50 + value/%s * 50) + '%%, %s ' + (50 + value/%s * 50) + '%%,%s 50%%,transparent 50%%)': 'linear-gradient(90deg, transparent, transparent 50%%, %s 50%%, %s ' + (50 + value/%s * 50) + '%%, transparent ' + (50 + value/%s * 50) + '%%)'",
max_val, color_pos, max_val, color_pos, color_neg, color_neg, max_val, max_val))
}
#' Maps numeric values to color values
#'
#' Maps numeric continuous values to values in a color palette
#'
#' @param x A character vector of numeric values (e.g. log2FoldChange values) to
#' be converted to a vector of colors
#' @param pal A vector of characters specifying the definition of colors for the
#' palette, e.g. obtained via \code{\link{brewer.pal}}
#' @param limits A vector containing the limits of the values to be mapped. If
#' not specified, defaults to the range of values in the `x` vector.
#'
#' @return A vector of colors, each corresponding to an element in the original
#' vector
#' @export
#'
#' @examples
#' a <- 1:9
#' pal <- RColorBrewer::brewer.pal(9,"Set1")
#' map2color(a, pal)
#' plot(a, col = map2color(a, pal), pch = 20, cex = 4)
#'
#' b <- 1:50
#' pal2 <- grDevices::colorRampPalette(
#' RColorBrewer::brewer.pal(name = "RdYlBu", 11))(50)
#' plot(b, col = map2color(b, pal2), pch = 20, cex = 3)
map2color <- function(x, pal, limits = NULL) {
if (is.null(limits))
limits <- range(x)
pal[findInterval(x, seq(limits[1],
limits[2],
length.out = length(pal) + 1),
all.inside = TRUE)]
}
#' Check colors
#'
#' Check correct specification of colors
#'
#' This is a vectorized version of [grDevices::col2rgb()]
#'
#' @param x A vector of strings specifying colors
#'
#' @return A vector of logical values, one for each specified color - `TRUE` if
#' the color is specified correctly
#' @export
#'
#' @examples
#' # simple case
#' mypal <- c("steelblue", "#FF1100")
#' check_colors(mypal)
#' mypal2 <- rev(
#' scales::alpha(
#' colorRampPalette(RColorBrewer::brewer.pal(name = "RdYlBu", 11))(50), 0.4))
#' check_colors(mypal2)
#' # useful with long vectors to check at once if all cols are fine
#' all(check_colors(mypal2))
check_colors <- function(x) {
vapply(x, function(col) {
tryCatch(is.matrix(col2rgb(col)),
error = function(e) FALSE)
}, logical(1))
}
#' Generate a table from the `DESeq2` results
#'
#' Generate a tidy table with the results of `DESeq2`
#'
#' @param res_de A `DESeqResults` object.
#' @param FDR Numeric value, specifying the significance level for thresholding
#' adjusted p-values. Defaults to NULL, which would return the full set of results
#' without performing any subsetting based on FDR.
#'
#' @return A tidy `data.frame` with the results from differential expression,
#' sorted by adjusted p-value. If FDR is specified, the table contains only genes
#' with adjusted p-value smaller than the value.
#'
#' @export
#'
#' @examples
#' data(res_de_macrophage, package = "GeneTonic")
#' head(res_macrophage_IFNg_vs_naive)
#' res_df <- deseqresult2df(res_macrophage_IFNg_vs_naive)
#' head(res_df)
deseqresult2df <- function(res_de, FDR = NULL) {
if (!is(res_de, "DESeqResults"))
stop("Not a DESeqResults object.")
res <- as.data.frame(res_de)
res <- cbind(rownames(res), res)
names(res)[1] <- "id"
res$id <- as.character(res$id)
res <- res[order(res$padj), ]
if (!is.null(FDR))
res <- res[!(is.na(res$padj)) & res$padj <= FDR, ]
res
}
#' Export to sif
#'
#' Export a graph to a Simple Interaction Format file
#'
#' @param g An `igraph` object
#' @param sif_file Character string, the path to the file where to save the exported
#' graph as .sif file
#' @param edge_label Character string, defining the name of the interaction type.
#' Defaults here to "relates_to"
#'
#' @return Returns the path to the exported file, invisibly
#'
#' @export
#'
#' @examples
#' library("igraph")
#' g <- make_full_graph(5) %du% make_full_graph(5) %du% make_full_graph(5)
#' g <- add_edges(g, c(1,6, 1,11, 6, 11))
#' export_to_sif(g, tempfile())
export_to_sif <- function(g, sif_file = "", edge_label = "relates_to") {
stopifnot(is(g, "igraph"))
stopifnot(is.character(sif_file) & length(sif_file) == 1)
sif_file <- normalizePath(sif_file, mustWork = FALSE)
stopifnot(is.character(edge_label) && length(edge_label) == 1)
el <- get.edgelist(g)
sif_df <- data.frame(
n1 = el[, 1],
edge_label = edge_label,
n2 = el[, 2]
)
message("Saving the file to ", sif_file)
write.table(sif_df, file = sif_file, sep = "\t", quote = FALSE,
col.names = FALSE, row.names = FALSE)
message("Done!")
return(invisible(sif_file))
}
GeneTonic_footer <- fluidRow(
column(
width = 1,
align = "right",
a(
href = "https://github.com/federicomarini/GeneTonic",
target = "_blank",
img(src = "GeneTonic/GeneTonic.png", height = "50px")
)
),
column(
width = 11,
align = "center",
"GeneTonic is a project developed by ",
tags$a(href = "https://federicomarini.github.io", "Federico Marini"),
" in the Bioinformatics division of the ",
tags$a(href = "http://www.unimedizin-mainz.de/imbei", "IMBEI"),
"- Institute for Medical Biostatistics, Epidemiology and Informatics", br(),
"License: ", tags$a(href = "https://opensource.org/licenses/MIT", "MIT"),
"- The GeneTonic package is developed and available on ",
tags$a(href = "https://github.com/federicomarini/GeneTonic", "GitHub")
)
)
# Shiny resource paths ----------------------------------------------------
.onLoad <- function(libname, pkgname) {
# Create link to logo
#nocov start
shiny::addResourcePath("GeneTonic", system.file("www", package = "GeneTonic"))
#nocov end
}
# Some constant values ----------------------------------------------------
.actionbutton_biocstyle <- "color: #ffffff; background-color: #0092AC"
.helpbutton_biocstyle <- "color: #0092AC; background-color: #FFFFFF; border-color: #FFFFFF"
# custom download button with icon and color tweaks
gt_downloadButton <- function(outputId,
label = "Download",
icon = "magic",
class = NULL,
...) {
aTag <- tags$a(id = outputId,
class = paste("btn btn-default shiny-download-link", class),
href = "",
target = "_blank",
download = NA,
icon(icon),
label)
}
.biocgreen <- "#0092AC"
