R/plotGenes.R
In PhanstielLab/BentoBox: Coordinate-Based Genomic Visualization Package for R
Defines functions
cutoffLabel
plotGenes
Documented in
plotGenes
#' Plot a gene track for a specified genomic region
#'
#' @usage plotGenes(
#' chrom,
#' chromstart = NULL,
#' chromend = NULL,
#' assembly = "hg38",
#' fontsize = 8,
#' fontcolor = c("#669fd9", "#abcc8e"),
#' fill = c("#669fd9", "#abcc8e"),
#' geneOrder = NULL,
#' geneHighlights = NULL,
#' geneBackground = "grey",
#' strandLabels = TRUE,
#' stroke = 0.1,
#' bg = NA,
#' x = NULL,
#' y = NULL,
#' width = NULL,
#' height = unit(0.6, "inches"),
#' just = c("left", "top"),
#' default.units = "inches",
#' draw = TRUE,
#' params = NULL
#' )
#'
#' @param chrom Chromosome of region to be plotted, as a string.
#' @param chromstart Integer start position on chromosome to be plotted.
#' @param chromend Integer end position on chromosome to be plotted.
#' @param assembly Default genome assembly as a string or a
#' \link[plotgardener]{assembly} object.
#' Default value is \code{assembly = "hg38"}.
#' @param fontsize A numeric specifying text fontsize in points.
#' Default value is \code{fontsize = 8}.
#' @param fontcolor A character value or vector of length 2 indicating
#' the fontcolors for the plus strand and minus strand gene labels.
#' The first value will color the plus strand gene labels and
#' the second value will color the minus strand gene labels.
#' Default value is \code{fontcolor = c("#669fd9", "#abcc8e")}.
#' @param fill A character value or vector of length 2 indicating the
#' strand fill colors for the plus strand and minus strand plot elements.
#' The first value will color the plus strand plot elements and
#' the second label will color the minus strand plot elements.
#' Default value is \code{fill = c("#669fd9", "#abcc8e")}.
#' @param geneOrder An ordered character vector of gene names to
#' prioritize when labeling genes.
#' @param geneHighlights A two-column dataframe with a column named "gene"
#' containing gene names as strings to highlight and a named column "color"
#' containing corresponding highlight colors.
#' @param geneBackground If \code{geneHighlights} is given, a character
#' value indicating the color for genes that are not highlighted.
#' @param strandLabels A logical value indicating whether to include
#' + and - strand labels to the left of the gene track.
#' @param stroke A numeric value indicating the stroke width for gene
#' body outlines. Default value is \code{stroke = 0.1}.
#' @param bg Character value indicating background color.
#' Default value is \code{bg = NA}.
#' @param x A numeric or unit object specifying genes plot x-location.
#' @param y A numeric, unit object, or character containing a "b"
#' combined with a numeric value specifying genes plot y-location.
#' The character value will
#' place the genes plot y relative to the bottom of the most recently
#' plotted plot according to the units of the plotgardener page.
#' @param width A numeric or unit object specifying genes plot width.
#' @param height A numeric or unit object specifying genes plot height.
#' @param just Justification of genes plot relative to its (x, y) location.
#' If there are two values, the first value specifies horizontal
#' justification and the second value specifies vertical justification.
#' Possible string values are: \code{"left"}, \code{"right"},
#' \code{"centre"}, \code{"center"}, \code{"bottom"}, and \code{"top"}.
#' Default value is \code{just = c("left", "top")}.
#' @param default.units A string indicating the default units to use if
#' \code{x}, \code{y}, \code{width}, or \code{height} are only given
#' as numerics. Default value is \code{default.units = "inches"}.
#' @param draw A logical value indicating whether graphics output
#' should be produced. Default value is \code{draw = TRUE}.
#' @param params An optional \link[plotgardener]{pgParams} object
#' containing relevant function parameters.
#'
#' @return Returns a \code{genes} object containing
#' relevant genomic region, placement, and \link[grid]{grob} information.
#'
#' @examples
#' ## Load hg19 genomic annotation packages
#' library("TxDb.Hsapiens.UCSC.hg19.knownGene")
#' library("org.Hs.eg.db")
#'
#' ## Set genomic coordinates
#' paramssmall <- pgParams(
#' chrom = "chr8",
#' chromstart = 1, chromend = 3000000,
#' assembly = "hg19", width = 7
#' )
#' paramsbig <- pgParams(
#' chrom = "chr8",
#' chromstart = 1, chromend = 146364022,
#' assembly = "hg19", width = 7
#' )
#' ## Set colors
#' cols <- c("#41B6C4", "#225EA8")
#'
#' ## Create page
#' pageCreate(width = 7.5, height = 3.5, default.units = "inches")
#'
#' ## Plot genes big
#' genesPlot <- plotGenes(
#' params = paramsbig, fill = cols,
#' fontcolor = cols,
#' x = 0.25, y = 0.25, height = 0.75,
#' just = c("left", "top"),
#' default.units = "inches"
#' )
#'
#' ## Annotate genome label
#' annoGenomeLabel(
#' plot = genesPlot, x = 0.25, y = 1.0,
#' scale = "Mb", just = c("left", "top")
#' )
#'
#' ## Plot genes small
#' genesPlot <- plotGenes(
#' params = paramssmall,
#' geneHighlights = data.frame(
#' "gene" = c("DLGAP2"),
#' "color" = c("#225EA8")
#' ),
#' geneBackground = "grey",
#' x = 0.25, y = 2.25, height = 0.75,
#' just = c("left", "top"), default.units = "inches"
#' )
#'
#' ## Annotate genome label
#' annoGenomeLabel(
#' plot = genesPlot, x = 0.25, y = 3.0, scale = "Mb",
#' just = c("left", "top")
#' )
#'
#' ## Hide page guides
#' pageGuideHide()
#' @details
#' A gene track can be placed on a page by providing
#' plot placement parameters:
#' \preformatted{
#' plotGenes(chrom, chromstart = NULL, chromend = NULL,
#' x, y, width, height, just = c("left", "top"),
#' default.units = "inches")
#' }
#' This function can be used to quickly plot an unnannotated gene track
#' by ignoring plot placement parameters:
#' \preformatted{
#' plotGenes(chrom, chromstart = NULL, chromend = NULL)
#' }
#'
#' Genomic annotation information is acquired through
#' \link[GenomicFeatures]{TxDb} and \link[AnnotationDbi]{OrgDb-class}
#' packages, as determined
#' through the \code{assembly} parameter. To avoid overcrowding of gene name
#' labels, plotted gene labels are by default prioritized according to
#' citation counts.
#'
#' @seealso \link[plotgardener]{assembly},
#' \link[plotgardener]{genomes}, \link[plotgardener]{defaultPackages}
#'
#' @export
plotGenes <- function(chrom, chromstart = NULL, chromend = NULL,
assembly = "hg38", fontsize = 8,
fontcolor = c("#669fd9", "#abcc8e"),
fill = c("#669fd9", "#abcc8e"),
geneOrder = NULL, geneHighlights = NULL,
geneBackground = "grey", strandLabels = TRUE,
stroke = 0.1, bg = NA, x = NULL, y = NULL,
width = NULL, height = unit(0.6, "inches"),
just = c("left", "top"), default.units = "inches",
draw = TRUE, params = NULL) {
# =========================================================================
# FUNCTIONS
# =========================================================================
## Define a function that checks errors for plotGenes
errorcheck_plotGenes <- function(chromstart, chromend, fill) {
## Genomic region errors
regionErrors(chromstart = chromstart, chromend = chromend)
## Make sure fill isn't colorby
checkColorby(fill = fill,
colorby = FALSE)
}
## Define a function that gets total lengths and centers of visible genes
get_geneCenters <- function(geneData, object) {
minStart <- min(geneData$TXSTART)
if (minStart < object$chromstart){
minStart <- object$chromstart
}
maxEnd <- max(geneData$TXEND)
if (maxEnd > object$chromend){
maxEnd <- object$chromend
}
geneLength <- maxEnd - minStart
geneCenter <- mean(c(minStart, maxEnd))
return(list(geneLength, geneCenter))
}
## Define a function that prioritizes genes based on internal
## priorities and/or user-defined geneOrder
gene_priorities <- function(genes, geneOrder, displayCol) {
## Split list into the ones in geneOrder and the ones not
subset <- genes[which(genes[[displayCol]] %in% geneOrder), ]
remaining <- genes[which(!genes[[displayCol]] %in% geneOrder), ]
## Put the geneOrder subset into the same order
subset <- subset[match(geneOrder, subset[[displayCol]]), ]
subset <- subset[which(!is.na(subset[[displayCol]])), ]
## Recombine lists, putting geneOrder section at the top
combined <- rbind(subset, remaining)
return(combined)
}
# =========================================================================
# PARSE PARAMETERS
# =========================================================================
genesInternal <- parseParams(
params = params,
defaultArgs = formals(eval(match.call()[[1]])),
declaredArgs = lapply(match.call()[-1], eval.parent, n = 2),
class = "genesInternal"
)
## Justification
genesInternal$just <- justConversion(just = genesInternal$just)
# =========================================================================
# INITIALIZE OBJECT
# =========================================================================
genes <- structure(list(
chrom = genesInternal$chrom,
chromstart = genesInternal$chromstart,
chromend = genesInternal$chromend,
assembly = genesInternal$assembly,
x = genesInternal$x, y = genesInternal$y,
width = genesInternal$width,
height = genesInternal$height,
just = genesInternal$just, grobs = NULL
),
class = "genes"
)
attr(x = genes, which = "plotted") <- genesInternal$draw
# =========================================================================
# CATCH ERRORS
# =========================================================================
if (is.null(genes$chrom)) stop("argument \"chrom\" is missing, ",
"with no default.", call. = FALSE)
errorcheck_plotGenes(
chromstart = genes$chromstart,
chromend = genes$chromend,
fill = genesInternal$fill
)
check_placement(object = genes)
# =========================================================================
# PARSE ASSEMBLY
# =========================================================================
genes$assembly <- parseAssembly(assembly = genes$assembly)
# =========================================================================
# PARSE UNITS
# =========================================================================
genes <- defaultUnits(
object = genes,
default.units = genesInternal$default.units
)
# =========================================================================
# GET APPROPRIATE BUILD DATA
# =========================================================================
buildData <- geneData(object = genes,
objectInternal = genesInternal)
genes <- buildData[[1]]
genesInternal <- buildData[[2]]
displayCol <- genesInternal$displayCol
# =========================================================================
# SUBSET DATA BY STRAND
# =========================================================================
data <- genesInternal$data
## Genes on plus strand and genes on minus strand
plus_genes <- data[which(data$TXSTRAND == "+"), ]
minus_genes <- data[which(data$TXSTRAND == "-"), ]
# =========================================================================
# COLORS AND HIGHLIGHTS
# =========================================================================
## If fontcolor and fill are length 1, change to length 2
if (length(genesInternal$fontcolor) == 1) {
genesInternal$fontcolor <- rep(genesInternal$fontcolor, 2)
}
if (length(genesInternal$fill) == 1) {
genesInternal$fill <- rep(genesInternal$fill, 2)
}
## Add strandColor and fontColors
if (nrow(plus_genes) > 0) {
plus_genes$strandColor <- genesInternal$fill[1]
plus_genes$fontColor <- genesInternal$fontcolor[1]
}
if (nrow(minus_genes) > 0) {
minus_genes$strandColor <- genesInternal$fill[2]
minus_genes$fontColor <- genesInternal$fontcolor[2]
}
## Find genes to be highlighted
if (!is.null(genesInternal$geneHighlights)) {
colnames(genesInternal$geneHighlights) <- c(
displayCol,
"strandColor"
)
plus_genes$strandColor <- NULL
minus_genes$strandColor <- NULL
plusHighlight <- plus_genes[which(plus_genes[[displayCol]] %in%
genesInternal$geneHighlights
[[displayCol]]), ]
minusHighlight <- minus_genes[which(minus_genes[[displayCol]] %in%
genesInternal$geneHighlights
[[displayCol]]), ]
plusBackground <- plus_genes[which(!plus_genes[[displayCol]] %in%
genesInternal$geneHighlights
[[displayCol]]), ]
minusBackground <- minus_genes[which(!minus_genes[[displayCol]] %in%
genesInternal$geneHighlights
[[displayCol]]), ]
# Change highlight genes to highlight color
plusHighlight <- merge(plusHighlight, genesInternal$geneHighlights,
by = displayCol
)
plusHighlight$fontColor <- plusHighlight$strandColor
minusHighlight <- merge(minusHighlight, genesInternal$geneHighlights,
by = displayCol
)
minusHighlight$fontColor <- minusHighlight$strandColor
# Change background genes to background color
plusBackground$strandColor <- rep(
genesInternal$geneBackground[1],
nrow(plusBackground)
)
plusBackground$fontColor <- rep(
genesInternal$geneBackground[1],
nrow(plusBackground)
)
minusBackground$strandColor <- rep(
genesInternal$geneBackground[1],
nrow(minusBackground)
)
minusBackground$fontColor <- rep(
genesInternal$geneBackground[1],
nrow(minusBackground)
)
## Automatically change fontcolor for +/- strand label
genesInternal$fontcolor[1] <- genesInternal$geneBackground[1]
genesInternal$fontcolor[2] <- genesInternal$geneBackground[1]
## Put highlight and background genes back together
plus_genes <- rbind(plusHighlight, plusBackground)
minus_genes <- rbind(minusHighlight, minusBackground)
}
# =========================================================================
# VIEWPORTS
# =========================================================================
## Define text grob for "+" and "-" viewport scaling
tG <- textGrob(label = "+", gp = gpar(
fontsize =
genesInternal$fontsize
))
if (is.null(genes$x) | is.null(genes$y)) {
if (genesInternal$strandLabels == TRUE) {
## Make viewport for "+" and "-" labels to the left of genetrack
# Calculate viewport with in temporary graphics device to avoid
# page
file <- file.path(tempdir(), "tG.pdf")
on.exit(unlink(file))
vp_labelW <- with_pdf(file,
width = dev.size()[1],
height = dev.size()[2],
convertWidth(widthDetails(tG) * 2,
unitTo = "npc"))
vp_label <- viewport(
height = unit(.12, "npc"),
width = vp_labelW,
x = unit(0, "npc"), y = unit(0.5, "npc"),
just = "left",
name = "genes1_label"
)
vp_gene <- viewport(
height = unit(.12, "npc"),
width = unit(1, "npc") - vp_labelW,
x = vp_labelW, y = unit(0.5, "npc"),
clip = "on",
xscale = genesInternal$xscale,
just = "left",
name = "genes1"
)
} else {
vp_gene <- viewport(
height = unit(.12, "npc"),
width = unit(1, "npc"),
x = unit(0, "npc"), y = unit(0.5, "npc"),
clip = "on",
xscale = genesInternal$xscale,
just = "left",
name = "genes1"
)
}
if (genesInternal$draw == TRUE) {
grid.newpage()
}
} else {
## Name viewport
currentViewports <- current_viewports()
vp_name <- paste0(
"genes",
length(intersect(
grep(
pattern = "genes",
x = currentViewports
),
grep(
pattern = "label",
x = currentViewports,
invert = TRUE
)
)) + 1
)
addViewport(vp_name)
## Convert coordinates into same units as page
page_coords <- convert_page(object = genes)
## Make viewport for gene track
vp_gene <- viewport(
height = page_coords$height,
width = page_coords$width,
x = page_coords$x, y = page_coords$y,
clip = "on",
xscale = genesInternal$xscale,
just = genesInternal$just,
name = vp_name
)
if (genesInternal$strandLabels == TRUE) {
## Make viewport for "+" and "-" labels based on above viewport
topLeft_vp <- vp_topLeft(viewport = vp_gene)
vp_label <- viewport(
height = page_coords$height,
width = convertWidth(widthDetails(tG) * 2,
unitTo = get("page_units",
envir = pgEnv
)
),
x = topLeft_vp[[1]], y = topLeft_vp[[2]],
just = c("right", "top"),
name = paste0(vp_name, "_label")
)
}
}
# =========================================================================
# INITIALIZE GTREE FOR GROBS WITH BACKGROUND
# =========================================================================
backgroundGrob <- rectGrob(
gp = gpar(
fill = genesInternal$bg,
col = NA
),
name = "background", vp = vp_gene
)
assign("gene_grobs", gTree(children = gList(backgroundGrob)),
envir = pgEnv
)
# =========================================================================
# MAKE GROBS
# =========================================================================
if (nrow(data) > 0) {
##########################################################
## GENE LINES ONLY
##########################################################
if ((genes$chromend - genes$chromstart) >= 25000000) {
if (nrow(plus_genes) > 0) {
plus_lines <- unique(plus_genes[,c("TXSTART", "TXEND",
"fontColor", "strandColor")])
plus_geneGrobs <- rectGrob(
x = plus_lines$TXSTART,
y = unit(0.63, "npc"),
width = plus_lines$TXEND - plus_lines$TXSTART,
height = unit(0.18, "npc"),
just = "left",
gp = gpar(
fill = plus_lines$strandColor,
col = plus_lines$strandColor,
lwd = genesInternal$stroke
),
vp = vp_gene, default.units = "native"
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = plus_geneGrobs
),
envir = pgEnv
)
}
if (nrow(minus_genes) > 0) {
minus_lines <- unique(minus_genes[,c("TXSTART", "TXEND",
"fontColor", "strandColor")])
minus_geneGrobs <- rectGrob(
x = minus_lines$TXSTART,
y = unit(0.37, "npc"),
width = minus_lines$TXEND - minus_lines$TXSTART,
height = unit(0.18, "npc"),
just = "left",
gp = gpar(
fill = minus_lines$strandColor,
col = minus_lines$strandColor,
lwd = genesInternal$stroke
),
vp = vp_gene, default.units = "native"
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = minus_geneGrobs
),
envir = pgEnv
)
}
} else {
if (nrow(plus_genes) > 0) {
##########################################################
## GENE LINES
##########################################################
plus_lines <- unique(plus_genes[,c("TXSTART", "TXEND",
"fontColor", "strandColor")])
plus_geneGrobs <- rectGrob(
x = plus_lines$TXSTART,
y = unit(0.63, "npc"),
width = plus_lines$TXEND - plus_lines$TXSTART,
height = unit(0.05, "npc"),
just = "left",
gp = gpar(
fill = plus_lines$strandColor,
col = plus_lines$strandColor,
lwd = genesInternal$stroke
),
vp = vp_gene, default.units = "native"
)
##########################################################
## GENE EXONS
###########################################################
plus_exonsGrobs <- rectGrob(
x = plus_genes$EXONSTART,
y = unit(0.63, "npc"),
width = plus_genes$EXONEND - plus_genes$EXONSTART,
height = unit(0.1, "npc"),
just = "left",
gp = gpar(
fill = plus_genes$strandColor,
col = NA
),
vp = vp_gene, default.units = "native"
)
##########################################################
## GENE CDS
##########################################################
## Get CDS regions that aren't NA
poscdsData <- plus_genes[which(!is.na(plus_genes$CDSSTART)), ]
if (nrow(poscdsData) > 0) {
plus_cdsGrobs <- rectGrob(
x = poscdsData$CDSSTART,
y = unit(0.63, "npc"),
width = poscdsData$CDSEND - poscdsData$CDSSTART,
height = unit(0.18, "npc"),
just = "left",
gp = gpar(
fill = poscdsData$strandColor,
col = poscdsData$strandColor,
lwd = 1.25
),
vp = vp_gene, default.units = "native"
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = plus_cdsGrobs
),
envir = pgEnv
)
}
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = plus_geneGrobs
),
envir = pgEnv
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = plus_exonsGrobs
),
envir = pgEnv
)
}
if (nrow(minus_genes) > 0) {
##########################################################
## GENE LINES
##########################################################
minus_lines <- unique(minus_genes[,c("TXSTART", "TXEND",
"fontColor", "strandColor")])
minus_geneGrobs <- rectGrob(
x = minus_lines$TXSTART,
y = unit(0.37, "npc"),
width = minus_lines$TXEND - minus_lines$TXSTART,
height = unit(0.05, "npc"),
just = "left",
gp = gpar(
fill = minus_lines$strandColor,
col = minus_lines$strandColor,
lwd = genesInternal$stroke
),
vp = vp_gene, default.units = "native"
)
##########################################################
## GENE EXONS
###########################################################
minus_exonsGrobs <- rectGrob(
x = minus_genes$EXONSTART,
y = unit(0.37, "npc"),
width = minus_genes$EXONEND - minus_genes$EXONSTART,
height = unit(0.1, "npc"),
just = "left",
gp = gpar(
fill = minus_genes$strandColor,
col = NA
),
vp = vp_gene, default.units = "native"
)
##########################################################
## GENE CDS
##########################################################
## Get CDS regions that aren't NA
mincdsData <- minus_genes[which(!is.na(minus_genes$CDSSTART)), ]
if (nrow(mincdsData) > 0) {
minus_cdsGrobs <- rectGrob(
x = mincdsData$CDSSTART,
y = unit(0.37, "npc"),
width = mincdsData$CDSEND - mincdsData$CDSSTART,
height = unit(0.18, "npc"),
just = "left",
gp = gpar(
fill = mincdsData$strandColor,
col = mincdsData$strandColor,
lwd = 1.25
),
vp = vp_gene, default.units = "native"
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = minus_cdsGrobs
),
envir = pgEnv
)
}
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = minus_geneGrobs
),
envir = pgEnv
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = minus_exonsGrobs
),
envir = pgEnv
)
}
}
##########################################################
## GENE NAME LABELS
##########################################################
## Split into mini dataframes based on GENEID
separatedplusGenes <- split(plus_genes, plus_genes$GENEID)
separatedminusGenes <- split(minus_genes, minus_genes$GENEID)
## For every GENEID dataframe, get length and center
## location of each total gene
plusgeneCenters <- lapply(separatedplusGenes, get_geneCenters,
object = genes)
plusgeneCenters <- data.frame(
GENEID = names(plusgeneCenters),
length = unlist(purrr::map(plusgeneCenters, 1)),
labelLoc = unlist(purrr::map(plusgeneCenters, 2))
)
minusgeneCenters <- lapply(separatedminusGenes, get_geneCenters,
object = genes)
minusgeneCenters <- data.frame(
GENEID = names(minusgeneCenters),
length = unlist(purrr::map(minusgeneCenters, 1)),
labelLoc = unlist(purrr::map(minusgeneCenters, 2))
)
## Get representative value of each shown gene name
plusgeneNames <- plus_genes[duplicated(plus_genes[[displayCol]]) ==
FALSE, ]
minusgeneNames <- minus_genes[duplicated(minus_genes[[displayCol]]) ==
FALSE, ]
## Add column with center location of each gene label
plusgeneNames <- suppressMessages(dplyr::left_join(
x = plusgeneNames,
y = plusgeneCenters,
by = "GENEID"
))
minusgeneNames <- suppressMessages(dplyr::left_join(
x = minusgeneNames,
y = minusgeneCenters,
by = "GENEID"
))
## Add all the gene names in the region to object
geneNames <- c(
plusgeneNames[[displayCol]],
minusgeneNames[[displayCol]]
)
genes$genes <- geneNames
## DECLUTTER LABELS
## Put genes in order of default gene prioritization
## based on citation/gene length
if (nrow(plusgeneNames) > 0){
## Put genes in order of default gene prioritization
## based on citation/gene length
plusgeneNames <- defaultGenePriorities(
data = plusgeneNames,
assembly = genes$assembly,
geneHighlights = genesInternal$geneHighlights[[displayCol]],
displayCol = displayCol
)
if (!is.null(genesInternal$geneOrder)) {
## Integrate geneOrder and default prioritization
plusgeneNames <- gene_priorities(
genes = plusgeneNames,
geneOrder = genesInternal$geneOrder,
displayCol = displayCol
)
}
## Get which gene names aren't cutoff
checkedplusLabels <- apply(data.frame(
"label" = plusgeneNames[[displayCol]],
"labelLoc" = plusgeneNames$labelLoc
),
1, cutoffLabel,
fontsize = genesInternal$fontsize,
xscale = genesInternal$xscale,
vp = vp_gene,
unit = "inches"
)
plusgeneNames[[displayCol]] <- checkedplusLabels
plusgeneNames <- plusgeneNames[!is.na(
plusgeneNames[[displayCol]]
), ]
if (nrow(plusgeneNames) > 0) {
plus_names <- textGrob(
label = plusgeneNames[[displayCol]],
x = plusgeneNames$labelLoc,
y = unit(0.85, "npc"),
gp = gpar(
col = plusgeneNames$fontColor,
fontsize = genesInternal$fontsize
),
vp = vp_gene,
default.units = "native",
check.overlap = TRUE
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = plus_names
),
envir = pgEnv
)
}
}
if (nrow(minusgeneNames) > 0) {
## Put genes in order of default gene prioritization
## based on citation/gene length
minusgeneNames <- defaultGenePriorities(
data = minusgeneNames,
assembly = genes$assembly,
geneHighlights = genesInternal$geneHighlights[[displayCol]],
displayCol = displayCol
)
if (!is.null(genesInternal$geneOrder)) {
## Integrate geneOrder and default prioritization
minusgeneNames <- gene_priorities(
genes = minusgeneNames,
geneOrder = genesInternal$geneOrder,
displayCol = displayCol
)
}
checkedminusLabels <- apply(data.frame(
"label" = minusgeneNames[[displayCol]],
"labelLoc" = minusgeneNames$labelLoc
),
1, cutoffLabel,
fontsize = genesInternal$fontsize,
xscale = genesInternal$xscale,
vp = vp_gene,
unit = "inches"
)
minusgeneNames[[displayCol]] <- checkedminusLabels
minusgeneNames <- minusgeneNames[!is.na(
minusgeneNames[[displayCol]]
), ]
if (nrow(minusgeneNames) > 0) {
minus_names <- textGrob(
label = minusgeneNames[[displayCol]],
x = minusgeneNames$labelLoc,
y = unit(0.15, "npc"),
gp = gpar(
col = minusgeneNames$fontColor,
fontsize = genesInternal$fontsize
),
vp = vp_gene,
default.units = "native",
check.overlap = TRUE
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = minus_names
),
envir = pgEnv
)
}
}
##########################################################
## + AND - LABELS
##########################################################
if (genesInternal$strandLabels == TRUE) {
plus_label <- textGrob(
label = "+", y = unit(0.63, "npc"),
gp = gpar(
fontsize = genesInternal$fontsize + 2,
col = genesInternal$fontcolor[1],
fontface = "bold"
), vp = vp_label
)
minus_label <- textGrob(
label = "-", y = unit(0.37, "npc"),
gp = gpar(
fontsize = genesInternal$fontsize + 2,
col = genesInternal$fontcolor[2],
fontface = "bold"
), vp = vp_label
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = plus_label
),
envir = pgEnv
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = minus_label
),
envir = pgEnv
)
}
}
# =========================================================================
# IF PLOT == TRUE, DRAW GROBS
# =========================================================================
if (genesInternal$draw == TRUE) {
grid.draw(get("gene_grobs", envir = pgEnv))
}
# =========================================================================
# ADD GROBS TO OBJECT
# =========================================================================
genes$grobs <- get("gene_grobs", envir = pgEnv)
# =========================================================================
# RETURN OBJECT
# =========================================================================
message("genes[", vp_gene$name, "]")
invisible(genes)
}
## Define a function that removes gene and transcript
## name labels that will be cutoff
## @param df data.frame of genes in region
## @param fontsize fontsize of labels
## @param xscale vector of genomic region of viewport
## @param vp associated viewport where genes/transcripts are plotted
## @param unit for plotTranscripts, unit indicator
cutoffLabel <- function(df, fontsize, xscale, vp, unit) {
label <- df[1]
location <- utils::type.convert(df[2], as.is = TRUE)
## Update viewport fontsize for proper text size calculation
vp$gp <- gpar(fontsize = fontsize)
if (unit == "npc"){
downViewport(name = vp$name)
labelWidth <- convertWidth(widthDetails(textGrob(
label = label,
gp = gpar(fontsize = fontsize)
)),
unitTo = "native", valueOnly = TRUE
)
upViewport()
} else {
pushViewport(vp)
labelWidth <- convertWidth(widthDetails(textGrob(
label = label,
gp = gpar(fontsize = fontsize)
)),
unitTo = "native", valueOnly = TRUE
)
upViewport()
}
leftBound <- location - 0.5 * labelWidth
rightBound <- location + 0.5 * labelWidth
if (leftBound < xscale[1] | rightBound > xscale[2]) {
return(NA)
} else {
return(label)
}
}
PhanstielLab/BentoBox documentation built on June 30, 2024, 12:50 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 cutoffLabel plotGenes
Documented in plotGenes
#' Plot a gene track for a specified genomic region
#'
#' @usage plotGenes(
#' chrom,
#' chromstart = NULL,
#' chromend = NULL,
#' assembly = "hg38",
#' fontsize = 8,
#' fontcolor = c("#669fd9", "#abcc8e"),
#' fill = c("#669fd9", "#abcc8e"),
#' geneOrder = NULL,
#' geneHighlights = NULL,
#' geneBackground = "grey",
#' strandLabels = TRUE,
#' stroke = 0.1,
#' bg = NA,
#' x = NULL,
#' y = NULL,
#' width = NULL,
#' height = unit(0.6, "inches"),
#' just = c("left", "top"),
#' default.units = "inches",
#' draw = TRUE,
#' params = NULL
#' )
#'
#' @param chrom Chromosome of region to be plotted, as a string.
#' @param chromstart Integer start position on chromosome to be plotted.
#' @param chromend Integer end position on chromosome to be plotted.
#' @param assembly Default genome assembly as a string or a
#' \link[plotgardener]{assembly} object.
#' Default value is \code{assembly = "hg38"}.
#' @param fontsize A numeric specifying text fontsize in points.
#' Default value is \code{fontsize = 8}.
#' @param fontcolor A character value or vector of length 2 indicating
#' the fontcolors for the plus strand and minus strand gene labels.
#' The first value will color the plus strand gene labels and
#' the second value will color the minus strand gene labels.
#' Default value is \code{fontcolor = c("#669fd9", "#abcc8e")}.
#' @param fill A character value or vector of length 2 indicating the
#' strand fill colors for the plus strand and minus strand plot elements.
#' The first value will color the plus strand plot elements and
#' the second label will color the minus strand plot elements.
#' Default value is \code{fill = c("#669fd9", "#abcc8e")}.
#' @param geneOrder An ordered character vector of gene names to
#' prioritize when labeling genes.
#' @param geneHighlights A two-column dataframe with a column named "gene"
#' containing gene names as strings to highlight and a named column "color"
#' containing corresponding highlight colors.
#' @param geneBackground If \code{geneHighlights} is given, a character
#' value indicating the color for genes that are not highlighted.
#' @param strandLabels A logical value indicating whether to include
#' + and - strand labels to the left of the gene track.
#' @param stroke A numeric value indicating the stroke width for gene
#' body outlines. Default value is \code{stroke = 0.1}.
#' @param bg Character value indicating background color.
#' Default value is \code{bg = NA}.
#' @param x A numeric or unit object specifying genes plot x-location.
#' @param y A numeric, unit object, or character containing a "b"
#' combined with a numeric value specifying genes plot y-location.
#' The character value will
#' place the genes plot y relative to the bottom of the most recently
#' plotted plot according to the units of the plotgardener page.
#' @param width A numeric or unit object specifying genes plot width.
#' @param height A numeric or unit object specifying genes plot height.
#' @param just Justification of genes plot relative to its (x, y) location.
#' If there are two values, the first value specifies horizontal
#' justification and the second value specifies vertical justification.
#' Possible string values are: \code{"left"}, \code{"right"},
#' \code{"centre"}, \code{"center"}, \code{"bottom"}, and \code{"top"}.
#' Default value is \code{just = c("left", "top")}.
#' @param default.units A string indicating the default units to use if
#' \code{x}, \code{y}, \code{width}, or \code{height} are only given
#' as numerics. Default value is \code{default.units = "inches"}.
#' @param draw A logical value indicating whether graphics output
#' should be produced. Default value is \code{draw = TRUE}.
#' @param params An optional \link[plotgardener]{pgParams} object
#' containing relevant function parameters.
#'
#' @return Returns a \code{genes} object containing
#' relevant genomic region, placement, and \link[grid]{grob} information.
#'
#' @examples
#' ## Load hg19 genomic annotation packages
#' library("TxDb.Hsapiens.UCSC.hg19.knownGene")
#' library("org.Hs.eg.db")
#'
#' ## Set genomic coordinates
#' paramssmall <- pgParams(
#' chrom = "chr8",
#' chromstart = 1, chromend = 3000000,
#' assembly = "hg19", width = 7
#' )
#' paramsbig <- pgParams(
#' chrom = "chr8",
#' chromstart = 1, chromend = 146364022,
#' assembly = "hg19", width = 7
#' )
#' ## Set colors
#' cols <- c("#41B6C4", "#225EA8")
#'
#' ## Create page
#' pageCreate(width = 7.5, height = 3.5, default.units = "inches")
#'
#' ## Plot genes big
#' genesPlot <- plotGenes(
#' params = paramsbig, fill = cols,
#' fontcolor = cols,
#' x = 0.25, y = 0.25, height = 0.75,
#' just = c("left", "top"),
#' default.units = "inches"
#' )
#'
#' ## Annotate genome label
#' annoGenomeLabel(
#' plot = genesPlot, x = 0.25, y = 1.0,
#' scale = "Mb", just = c("left", "top")
#' )
#'
#' ## Plot genes small
#' genesPlot <- plotGenes(
#' params = paramssmall,
#' geneHighlights = data.frame(
#' "gene" = c("DLGAP2"),
#' "color" = c("#225EA8")
#' ),
#' geneBackground = "grey",
#' x = 0.25, y = 2.25, height = 0.75,
#' just = c("left", "top"), default.units = "inches"
#' )
#'
#' ## Annotate genome label
#' annoGenomeLabel(
#' plot = genesPlot, x = 0.25, y = 3.0, scale = "Mb",
#' just = c("left", "top")
#' )
#'
#' ## Hide page guides
#' pageGuideHide()
#' @details
#' A gene track can be placed on a page by providing
#' plot placement parameters:
#' \preformatted{
#' plotGenes(chrom, chromstart = NULL, chromend = NULL,
#' x, y, width, height, just = c("left", "top"),
#' default.units = "inches")
#' }
#' This function can be used to quickly plot an unnannotated gene track
#' by ignoring plot placement parameters:
#' \preformatted{
#' plotGenes(chrom, chromstart = NULL, chromend = NULL)
#' }
#'
#' Genomic annotation information is acquired through
#' \link[GenomicFeatures]{TxDb} and \link[AnnotationDbi]{OrgDb-class}
#' packages, as determined
#' through the \code{assembly} parameter. To avoid overcrowding of gene name
#' labels, plotted gene labels are by default prioritized according to
#' citation counts.
#'
#' @seealso \link[plotgardener]{assembly},
#' \link[plotgardener]{genomes}, \link[plotgardener]{defaultPackages}
#'
#' @export
plotGenes <- function(chrom, chromstart = NULL, chromend = NULL,
assembly = "hg38", fontsize = 8,
fontcolor = c("#669fd9", "#abcc8e"),
fill = c("#669fd9", "#abcc8e"),
geneOrder = NULL, geneHighlights = NULL,
geneBackground = "grey", strandLabels = TRUE,
stroke = 0.1, bg = NA, x = NULL, y = NULL,
width = NULL, height = unit(0.6, "inches"),
just = c("left", "top"), default.units = "inches",
draw = TRUE, params = NULL) {
# =========================================================================
# FUNCTIONS
# =========================================================================
## Define a function that checks errors for plotGenes
errorcheck_plotGenes <- function(chromstart, chromend, fill) {
## Genomic region errors
regionErrors(chromstart = chromstart, chromend = chromend)
## Make sure fill isn't colorby
checkColorby(fill = fill,
colorby = FALSE)
}
## Define a function that gets total lengths and centers of visible genes
get_geneCenters <- function(geneData, object) {
minStart <- min(geneData$TXSTART)
if (minStart < object$chromstart){
minStart <- object$chromstart
}
maxEnd <- max(geneData$TXEND)
if (maxEnd > object$chromend){
maxEnd <- object$chromend
}
geneLength <- maxEnd - minStart
geneCenter <- mean(c(minStart, maxEnd))
return(list(geneLength, geneCenter))
}
## Define a function that prioritizes genes based on internal
## priorities and/or user-defined geneOrder
gene_priorities <- function(genes, geneOrder, displayCol) {
## Split list into the ones in geneOrder and the ones not
subset <- genes[which(genes[[displayCol]] %in% geneOrder), ]
remaining <- genes[which(!genes[[displayCol]] %in% geneOrder), ]
## Put the geneOrder subset into the same order
subset <- subset[match(geneOrder, subset[[displayCol]]), ]
subset <- subset[which(!is.na(subset[[displayCol]])), ]
## Recombine lists, putting geneOrder section at the top
combined <- rbind(subset, remaining)
return(combined)
}
# =========================================================================
# PARSE PARAMETERS
# =========================================================================
genesInternal <- parseParams(
params = params,
defaultArgs = formals(eval(match.call()[[1]])),
declaredArgs = lapply(match.call()[-1], eval.parent, n = 2),
class = "genesInternal"
)
## Justification
genesInternal$just <- justConversion(just = genesInternal$just)
# =========================================================================
# INITIALIZE OBJECT
# =========================================================================
genes <- structure(list(
chrom = genesInternal$chrom,
chromstart = genesInternal$chromstart,
chromend = genesInternal$chromend,
assembly = genesInternal$assembly,
x = genesInternal$x, y = genesInternal$y,
width = genesInternal$width,
height = genesInternal$height,
just = genesInternal$just, grobs = NULL
),
class = "genes"
)
attr(x = genes, which = "plotted") <- genesInternal$draw
# =========================================================================
# CATCH ERRORS
# =========================================================================
if (is.null(genes$chrom)) stop("argument \"chrom\" is missing, ",
"with no default.", call. = FALSE)
errorcheck_plotGenes(
chromstart = genes$chromstart,
chromend = genes$chromend,
fill = genesInternal$fill
)
check_placement(object = genes)
# =========================================================================
# PARSE ASSEMBLY
# =========================================================================
genes$assembly <- parseAssembly(assembly = genes$assembly)
# =========================================================================
# PARSE UNITS
# =========================================================================
genes <- defaultUnits(
object = genes,
default.units = genesInternal$default.units
)
# =========================================================================
# GET APPROPRIATE BUILD DATA
# =========================================================================
buildData <- geneData(object = genes,
objectInternal = genesInternal)
genes <- buildData[[1]]
genesInternal <- buildData[[2]]
displayCol <- genesInternal$displayCol
# =========================================================================
# SUBSET DATA BY STRAND
# =========================================================================
data <- genesInternal$data
## Genes on plus strand and genes on minus strand
plus_genes <- data[which(data$TXSTRAND == "+"), ]
minus_genes <- data[which(data$TXSTRAND == "-"), ]
# =========================================================================
# COLORS AND HIGHLIGHTS
# =========================================================================
## If fontcolor and fill are length 1, change to length 2
if (length(genesInternal$fontcolor) == 1) {
genesInternal$fontcolor <- rep(genesInternal$fontcolor, 2)
}
if (length(genesInternal$fill) == 1) {
genesInternal$fill <- rep(genesInternal$fill, 2)
}
## Add strandColor and fontColors
if (nrow(plus_genes) > 0) {
plus_genes$strandColor <- genesInternal$fill[1]
plus_genes$fontColor <- genesInternal$fontcolor[1]
}
if (nrow(minus_genes) > 0) {
minus_genes$strandColor <- genesInternal$fill[2]
minus_genes$fontColor <- genesInternal$fontcolor[2]
}
## Find genes to be highlighted
if (!is.null(genesInternal$geneHighlights)) {
colnames(genesInternal$geneHighlights) <- c(
displayCol,
"strandColor"
)
plus_genes$strandColor <- NULL
minus_genes$strandColor <- NULL
plusHighlight <- plus_genes[which(plus_genes[[displayCol]] %in%
genesInternal$geneHighlights
[[displayCol]]), ]
minusHighlight <- minus_genes[which(minus_genes[[displayCol]] %in%
genesInternal$geneHighlights
[[displayCol]]), ]
plusBackground <- plus_genes[which(!plus_genes[[displayCol]] %in%
genesInternal$geneHighlights
[[displayCol]]), ]
minusBackground <- minus_genes[which(!minus_genes[[displayCol]] %in%
genesInternal$geneHighlights
[[displayCol]]), ]
# Change highlight genes to highlight color
plusHighlight <- merge(plusHighlight, genesInternal$geneHighlights,
by = displayCol
)
plusHighlight$fontColor <- plusHighlight$strandColor
minusHighlight <- merge(minusHighlight, genesInternal$geneHighlights,
by = displayCol
)
minusHighlight$fontColor <- minusHighlight$strandColor
# Change background genes to background color
plusBackground$strandColor <- rep(
genesInternal$geneBackground[1],
nrow(plusBackground)
)
plusBackground$fontColor <- rep(
genesInternal$geneBackground[1],
nrow(plusBackground)
)
minusBackground$strandColor <- rep(
genesInternal$geneBackground[1],
nrow(minusBackground)
)
minusBackground$fontColor <- rep(
genesInternal$geneBackground[1],
nrow(minusBackground)
)
## Automatically change fontcolor for +/- strand label
genesInternal$fontcolor[1] <- genesInternal$geneBackground[1]
genesInternal$fontcolor[2] <- genesInternal$geneBackground[1]
## Put highlight and background genes back together
plus_genes <- rbind(plusHighlight, plusBackground)
minus_genes <- rbind(minusHighlight, minusBackground)
}
# =========================================================================
# VIEWPORTS
# =========================================================================
## Define text grob for "+" and "-" viewport scaling
tG <- textGrob(label = "+", gp = gpar(
fontsize =
genesInternal$fontsize
))
if (is.null(genes$x) | is.null(genes$y)) {
if (genesInternal$strandLabels == TRUE) {
## Make viewport for "+" and "-" labels to the left of genetrack
# Calculate viewport with in temporary graphics device to avoid
# page
file <- file.path(tempdir(), "tG.pdf")
on.exit(unlink(file))
vp_labelW <- with_pdf(file,
width = dev.size()[1],
height = dev.size()[2],
convertWidth(widthDetails(tG) * 2,
unitTo = "npc"))
vp_label <- viewport(
height = unit(.12, "npc"),
width = vp_labelW,
x = unit(0, "npc"), y = unit(0.5, "npc"),
just = "left",
name = "genes1_label"
)
vp_gene <- viewport(
height = unit(.12, "npc"),
width = unit(1, "npc") - vp_labelW,
x = vp_labelW, y = unit(0.5, "npc"),
clip = "on",
xscale = genesInternal$xscale,
just = "left",
name = "genes1"
)
} else {
vp_gene <- viewport(
height = unit(.12, "npc"),
width = unit(1, "npc"),
x = unit(0, "npc"), y = unit(0.5, "npc"),
clip = "on",
xscale = genesInternal$xscale,
just = "left",
name = "genes1"
)
}
if (genesInternal$draw == TRUE) {
grid.newpage()
}
} else {
## Name viewport
currentViewports <- current_viewports()
vp_name <- paste0(
"genes",
length(intersect(
grep(
pattern = "genes",
x = currentViewports
),
grep(
pattern = "label",
x = currentViewports,
invert = TRUE
)
)) + 1
)
addViewport(vp_name)
## Convert coordinates into same units as page
page_coords <- convert_page(object = genes)
## Make viewport for gene track
vp_gene <- viewport(
height = page_coords$height,
width = page_coords$width,
x = page_coords$x, y = page_coords$y,
clip = "on",
xscale = genesInternal$xscale,
just = genesInternal$just,
name = vp_name
)
if (genesInternal$strandLabels == TRUE) {
## Make viewport for "+" and "-" labels based on above viewport
topLeft_vp <- vp_topLeft(viewport = vp_gene)
vp_label <- viewport(
height = page_coords$height,
width = convertWidth(widthDetails(tG) * 2,
unitTo = get("page_units",
envir = pgEnv
)
),
x = topLeft_vp[[1]], y = topLeft_vp[[2]],
just = c("right", "top"),
name = paste0(vp_name, "_label")
)
}
}
# =========================================================================
# INITIALIZE GTREE FOR GROBS WITH BACKGROUND
# =========================================================================
backgroundGrob <- rectGrob(
gp = gpar(
fill = genesInternal$bg,
col = NA
),
name = "background", vp = vp_gene
)
assign("gene_grobs", gTree(children = gList(backgroundGrob)),
envir = pgEnv
)
# =========================================================================
# MAKE GROBS
# =========================================================================
if (nrow(data) > 0) {
##########################################################
## GENE LINES ONLY
##########################################################
if ((genes$chromend - genes$chromstart) >= 25000000) {
if (nrow(plus_genes) > 0) {
plus_lines <- unique(plus_genes[,c("TXSTART", "TXEND",
"fontColor", "strandColor")])
plus_geneGrobs <- rectGrob(
x = plus_lines$TXSTART,
y = unit(0.63, "npc"),
width = plus_lines$TXEND - plus_lines$TXSTART,
height = unit(0.18, "npc"),
just = "left",
gp = gpar(
fill = plus_lines$strandColor,
col = plus_lines$strandColor,
lwd = genesInternal$stroke
),
vp = vp_gene, default.units = "native"
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = plus_geneGrobs
),
envir = pgEnv
)
}
if (nrow(minus_genes) > 0) {
minus_lines <- unique(minus_genes[,c("TXSTART", "TXEND",
"fontColor", "strandColor")])
minus_geneGrobs <- rectGrob(
x = minus_lines$TXSTART,
y = unit(0.37, "npc"),
width = minus_lines$TXEND - minus_lines$TXSTART,
height = unit(0.18, "npc"),
just = "left",
gp = gpar(
fill = minus_lines$strandColor,
col = minus_lines$strandColor,
lwd = genesInternal$stroke
),
vp = vp_gene, default.units = "native"
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = minus_geneGrobs
),
envir = pgEnv
)
}
} else {
if (nrow(plus_genes) > 0) {
##########################################################
## GENE LINES
##########################################################
plus_lines <- unique(plus_genes[,c("TXSTART", "TXEND",
"fontColor", "strandColor")])
plus_geneGrobs <- rectGrob(
x = plus_lines$TXSTART,
y = unit(0.63, "npc"),
width = plus_lines$TXEND - plus_lines$TXSTART,
height = unit(0.05, "npc"),
just = "left",
gp = gpar(
fill = plus_lines$strandColor,
col = plus_lines$strandColor,
lwd = genesInternal$stroke
),
vp = vp_gene, default.units = "native"
)
##########################################################
## GENE EXONS
###########################################################
plus_exonsGrobs <- rectGrob(
x = plus_genes$EXONSTART,
y = unit(0.63, "npc"),
width = plus_genes$EXONEND - plus_genes$EXONSTART,
height = unit(0.1, "npc"),
just = "left",
gp = gpar(
fill = plus_genes$strandColor,
col = NA
),
vp = vp_gene, default.units = "native"
)
##########################################################
## GENE CDS
##########################################################
## Get CDS regions that aren't NA
poscdsData <- plus_genes[which(!is.na(plus_genes$CDSSTART)), ]
if (nrow(poscdsData) > 0) {
plus_cdsGrobs <- rectGrob(
x = poscdsData$CDSSTART,
y = unit(0.63, "npc"),
width = poscdsData$CDSEND - poscdsData$CDSSTART,
height = unit(0.18, "npc"),
just = "left",
gp = gpar(
fill = poscdsData$strandColor,
col = poscdsData$strandColor,
lwd = 1.25
),
vp = vp_gene, default.units = "native"
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = plus_cdsGrobs
),
envir = pgEnv
)
}
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = plus_geneGrobs
),
envir = pgEnv
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = plus_exonsGrobs
),
envir = pgEnv
)
}
if (nrow(minus_genes) > 0) {
##########################################################
## GENE LINES
##########################################################
minus_lines <- unique(minus_genes[,c("TXSTART", "TXEND",
"fontColor", "strandColor")])
minus_geneGrobs <- rectGrob(
x = minus_lines$TXSTART,
y = unit(0.37, "npc"),
width = minus_lines$TXEND - minus_lines$TXSTART,
height = unit(0.05, "npc"),
just = "left",
gp = gpar(
fill = minus_lines$strandColor,
col = minus_lines$strandColor,
lwd = genesInternal$stroke
),
vp = vp_gene, default.units = "native"
)
##########################################################
## GENE EXONS
###########################################################
minus_exonsGrobs <- rectGrob(
x = minus_genes$EXONSTART,
y = unit(0.37, "npc"),
width = minus_genes$EXONEND - minus_genes$EXONSTART,
height = unit(0.1, "npc"),
just = "left",
gp = gpar(
fill = minus_genes$strandColor,
col = NA
),
vp = vp_gene, default.units = "native"
)
##########################################################
## GENE CDS
##########################################################
## Get CDS regions that aren't NA
mincdsData <- minus_genes[which(!is.na(minus_genes$CDSSTART)), ]
if (nrow(mincdsData) > 0) {
minus_cdsGrobs <- rectGrob(
x = mincdsData$CDSSTART,
y = unit(0.37, "npc"),
width = mincdsData$CDSEND - mincdsData$CDSSTART,
height = unit(0.18, "npc"),
just = "left",
gp = gpar(
fill = mincdsData$strandColor,
col = mincdsData$strandColor,
lwd = 1.25
),
vp = vp_gene, default.units = "native"
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = minus_cdsGrobs
),
envir = pgEnv
)
}
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = minus_geneGrobs
),
envir = pgEnv
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = minus_exonsGrobs
),
envir = pgEnv
)
}
}
##########################################################
## GENE NAME LABELS
##########################################################
## Split into mini dataframes based on GENEID
separatedplusGenes <- split(plus_genes, plus_genes$GENEID)
separatedminusGenes <- split(minus_genes, minus_genes$GENEID)
## For every GENEID dataframe, get length and center
## location of each total gene
plusgeneCenters <- lapply(separatedplusGenes, get_geneCenters,
object = genes)
plusgeneCenters <- data.frame(
GENEID = names(plusgeneCenters),
length = unlist(purrr::map(plusgeneCenters, 1)),
labelLoc = unlist(purrr::map(plusgeneCenters, 2))
)
minusgeneCenters <- lapply(separatedminusGenes, get_geneCenters,
object = genes)
minusgeneCenters <- data.frame(
GENEID = names(minusgeneCenters),
length = unlist(purrr::map(minusgeneCenters, 1)),
labelLoc = unlist(purrr::map(minusgeneCenters, 2))
)
## Get representative value of each shown gene name
plusgeneNames <- plus_genes[duplicated(plus_genes[[displayCol]]) ==
FALSE, ]
minusgeneNames <- minus_genes[duplicated(minus_genes[[displayCol]]) ==
FALSE, ]
## Add column with center location of each gene label
plusgeneNames <- suppressMessages(dplyr::left_join(
x = plusgeneNames,
y = plusgeneCenters,
by = "GENEID"
))
minusgeneNames <- suppressMessages(dplyr::left_join(
x = minusgeneNames,
y = minusgeneCenters,
by = "GENEID"
))
## Add all the gene names in the region to object
geneNames <- c(
plusgeneNames[[displayCol]],
minusgeneNames[[displayCol]]
)
genes$genes <- geneNames
## DECLUTTER LABELS
## Put genes in order of default gene prioritization
## based on citation/gene length
if (nrow(plusgeneNames) > 0){
## Put genes in order of default gene prioritization
## based on citation/gene length
plusgeneNames <- defaultGenePriorities(
data = plusgeneNames,
assembly = genes$assembly,
geneHighlights = genesInternal$geneHighlights[[displayCol]],
displayCol = displayCol
)
if (!is.null(genesInternal$geneOrder)) {
## Integrate geneOrder and default prioritization
plusgeneNames <- gene_priorities(
genes = plusgeneNames,
geneOrder = genesInternal$geneOrder,
displayCol = displayCol
)
}
## Get which gene names aren't cutoff
checkedplusLabels <- apply(data.frame(
"label" = plusgeneNames[[displayCol]],
"labelLoc" = plusgeneNames$labelLoc
),
1, cutoffLabel,
fontsize = genesInternal$fontsize,
xscale = genesInternal$xscale,
vp = vp_gene,
unit = "inches"
)
plusgeneNames[[displayCol]] <- checkedplusLabels
plusgeneNames <- plusgeneNames[!is.na(
plusgeneNames[[displayCol]]
), ]
if (nrow(plusgeneNames) > 0) {
plus_names <- textGrob(
label = plusgeneNames[[displayCol]],
x = plusgeneNames$labelLoc,
y = unit(0.85, "npc"),
gp = gpar(
col = plusgeneNames$fontColor,
fontsize = genesInternal$fontsize
),
vp = vp_gene,
default.units = "native",
check.overlap = TRUE
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = plus_names
),
envir = pgEnv
)
}
}
if (nrow(minusgeneNames) > 0) {
## Put genes in order of default gene prioritization
## based on citation/gene length
minusgeneNames <- defaultGenePriorities(
data = minusgeneNames,
assembly = genes$assembly,
geneHighlights = genesInternal$geneHighlights[[displayCol]],
displayCol = displayCol
)
if (!is.null(genesInternal$geneOrder)) {
## Integrate geneOrder and default prioritization
minusgeneNames <- gene_priorities(
genes = minusgeneNames,
geneOrder = genesInternal$geneOrder,
displayCol = displayCol
)
}
checkedminusLabels <- apply(data.frame(
"label" = minusgeneNames[[displayCol]],
"labelLoc" = minusgeneNames$labelLoc
),
1, cutoffLabel,
fontsize = genesInternal$fontsize,
xscale = genesInternal$xscale,
vp = vp_gene,
unit = "inches"
)
minusgeneNames[[displayCol]] <- checkedminusLabels
minusgeneNames <- minusgeneNames[!is.na(
minusgeneNames[[displayCol]]
), ]
if (nrow(minusgeneNames) > 0) {
minus_names <- textGrob(
label = minusgeneNames[[displayCol]],
x = minusgeneNames$labelLoc,
y = unit(0.15, "npc"),
gp = gpar(
col = minusgeneNames$fontColor,
fontsize = genesInternal$fontsize
),
vp = vp_gene,
default.units = "native",
check.overlap = TRUE
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = minus_names
),
envir = pgEnv
)
}
}
##########################################################
## + AND - LABELS
##########################################################
if (genesInternal$strandLabels == TRUE) {
plus_label <- textGrob(
label = "+", y = unit(0.63, "npc"),
gp = gpar(
fontsize = genesInternal$fontsize + 2,
col = genesInternal$fontcolor[1],
fontface = "bold"
), vp = vp_label
)
minus_label <- textGrob(
label = "-", y = unit(0.37, "npc"),
gp = gpar(
fontsize = genesInternal$fontsize + 2,
col = genesInternal$fontcolor[2],
fontface = "bold"
), vp = vp_label
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = plus_label
),
envir = pgEnv
)
assign("gene_grobs",
addGrob(get("gene_grobs", envir = pgEnv),
child = minus_label
),
envir = pgEnv
)
}
}
# =========================================================================
# IF PLOT == TRUE, DRAW GROBS
# =========================================================================
if (genesInternal$draw == TRUE) {
grid.draw(get("gene_grobs", envir = pgEnv))
}
# =========================================================================
# ADD GROBS TO OBJECT
# =========================================================================
genes$grobs <- get("gene_grobs", envir = pgEnv)
# =========================================================================
# RETURN OBJECT
# =========================================================================
message("genes[", vp_gene$name, "]")
invisible(genes)
}
## Define a function that removes gene and transcript
## name labels that will be cutoff
## @param df data.frame of genes in region
## @param fontsize fontsize of labels
## @param xscale vector of genomic region of viewport
## @param vp associated viewport where genes/transcripts are plotted
## @param unit for plotTranscripts, unit indicator
cutoffLabel <- function(df, fontsize, xscale, vp, unit) {
label <- df[1]
location <- utils::type.convert(df[2], as.is = TRUE)
## Update viewport fontsize for proper text size calculation
vp$gp <- gpar(fontsize = fontsize)
if (unit == "npc"){
downViewport(name = vp$name)
labelWidth <- convertWidth(widthDetails(textGrob(
label = label,
gp = gpar(fontsize = fontsize)
)),
unitTo = "native", valueOnly = TRUE
)
upViewport()
} else {
pushViewport(vp)
labelWidth <- convertWidth(widthDetails(textGrob(
label = label,
gp = gpar(fontsize = fontsize)
)),
unitTo = "native", valueOnly = TRUE
)
upViewport()
}
leftBound <- location - 0.5 * labelWidth
rightBound <- location + 0.5 * labelWidth
if (leftBound < xscale[1] | rightBound > xscale[2]) {
return(NA)
} else {
return(label)
}
}
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.