R/plotGenomeLabel.R
In PhanstielLab/plotgardener: Coordinate-Based Genomic Visualization Package for R
Defines functions
plotManhattanGenomeLabel
plotChromGenomeLabel
plotGenomeLabel
Documented in
plotGenomeLabel
#' Plot genomic coordinates along the x or y-axis of a plotgardener plot
#'
#' @usage plotGenomeLabel(
#' chrom,
#' chromstart = NULL,
#' chromend = NULL,
#' assembly = "hg38",
#' fontsize = 10,
#' fontcolor = "black",
#' linecolor = "black",
#' margin = unit(1, "mm"),
#' scale = "bp",
#' commas = TRUE,
#' sequence = TRUE,
#' boxWidth = 0.5,
#' axis = "x",
#' at = NULL,
#' tcl = 0.5,
#' x,
#' y,
#' length,
#' just = c("left", "top"),
#' default.units = "inches",
#' params = NULL,
#' ...
#' )
#'
#' @param chrom Chromosome of genome label, as a string,
#' or a character vector of chromosomes for a whole genome Manhattan plot.
#' @param chromstart Integer start of genome label.
#' @param chromend Integer end of genome label.
#' @param assembly Default genome assembly as a string or a
#' \link[plotgardener]{assembly} object.
#' @param fontsize A numeric specifying text fontsize in points.
#' Default value is \code{fontsize = 10}.
#' @param fontcolor A character value indicating the color for text.
#' Default value is \code{fontcolor = "black"}.
#' @param linecolor A character value indicating the color of
#' the genome label axis. Default value is \code{linecolor = "black"}.
#' @param margin A numeric or unit vector specifying space between axis
#' and coordinate labels. Default value is \code{margin = unit(1, "mm")},
#' @param scale A character value indicating the scale of the coordinates
#' along the genome label. Default value is \code{scale = "bp"}. Options are:
#' \itemize{
#' \item{\code{"bp"}: }{base pairs.}
#' \item{\code{"Kb"}: }{kilobase pairs. 1 kilobase pair is equal to
#' 1000 base pairs.}
#' \item{\code{"Mb"}: }{megabase pairs. 1 megabase pair is equal to
#' 1000000 base pairs.}
#' }
#' @param commas A logical value indicating whether to include commas in
#' start and stop labels. Default value is \code{commas = TRUE}.
#' @param sequence A logical value indicating whether to include sequence
#' information above the label of an x-axis (only at appropriate resolutions).
#' @param boxWidth A numeric value indicating the width of the boxes
#' representing sequence information at appropriate resolutions.
#' Default value is \code{boxWidth = 0.5}.
#' @param axis A character value indicating along which axis to
#' add genome label. Sequence information will not be displayed along a y-axis.
#' Default value is \code{axis = "x"}.
#' Options are:
#' \itemize{
#' \item{\code{"x"}: }{Genome label will be plotted along the x-axis.}
#' \item{\code{"y"}: }{Genome label will be plotted along the y-axis.
#' This is typically used for a square Hi-C plot made with
#' \code{plotHicSquare}.}
#' }
#' @param at A numeric vector of x-value locations for tick marks.
#' @param tcl A numeric specifying the length of tickmarks as a
#' fraction of text height. Default value is \code{tcl = 0.5}.
#' @param x A numeric or unit object specifying genome label x-location.
#' @param y A numeric, unit object, or character containing a "b"
#' combined with a numeric value specifying genome label y-location.
#' The character value will
#' place the genome label y relative to the bottom of the most recently
#' plotted plot according to the units of the plotgardener page.
#' @param length A numeric or unit object specifying length of
#' genome label axis.
#' @param just Justification of genome label 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}, or \code{length} are only given as numerics.
#' Default value is \code{default.units = "inches"}.
#' @param params An optional \link[plotgardener]{pgParams} object
#' containing relevant function parameters.
#' @param ... Additional grid graphical parameters or digit specifications.
#' See \link[grid]{gpar} and \link[base]{formatC}.
#'
#' @return Returns a \code{genomeLabel} 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")
#' library("BSgenome.Hsapiens.UCSC.hg19")
#'
#' ## Create page
#' pageCreate(width = 5, height = 3, default.units = "inches")
#'
#' ## Plot and place gene track on page
#' genesPlot <- plotGenes(
#' chrom = "chr8",
#' chromstart = 1000000, chromend = 2000000,
#' assembly = "hg19", fill = c("grey", "grey"),
#' fontcolor = c("grey", "grey"),
#' x = 0.5, y = 0.25, width = 4, height = 1,
#' just = c("left", "top"),
#' default.units = "inches"
#' )
#'
#' ## Plot x-axis genome labels at different scales
#' plotGenomeLabel(
#' chrom = "chr8",
#' chromstart = 1000000, chromend = 2000000,
#' assembly = "hg19",
#' scale = "Mb",
#' x = 0.5, y = 1.25, length = 4, just = c("left", "top"),
#' default.units = "inches"
#' )
#' plotGenomeLabel(
#' chrom = "chr8",
#' chromstart = 1000000, chromend = 2000000,
#' assembly = "hg19",
#' scale = "Kb",
#' x = 0.5, y = 1.5, length = 4, just = c("left", "top"),
#' default.units = "inches"
#' )
#' plotGenomeLabel(
#' chrom = "chr8",
#' chromstart = 1000000, chromend = 2000000,
#' assembly = "hg19",
#' scale = "bp",
#' x = 0.5, y = 1.75, length = 4, just = c("left", "top"),
#' default.units = "inches"
#' )
#'
#' ## Plot a different genomic label region, zooming in enough
#' ## to see base pairs
#' plotGenomeLabel(
#' chrom = "chr8",
#' chromstart = 1000000, chromend = 1000050,
#' assembly = "hg19",
#' x = 0.25, y = 2.2, length = 4.5
#' )
#' plotGenomeLabel(
#' chrom = "chr8",
#' chromstart = 1000000, chromend = 1000020,
#' assembly = "hg19",
#' x = 0, y = 2.6, length = 5
#' )
#'
#' ## Hide page guides
#' pageGuideHide()
#' @export
plotGenomeLabel <- function(chrom, chromstart = NULL, chromend = NULL,
assembly = "hg38", fontsize = 10,
fontcolor = "black", linecolor = "black",
margin = unit(1, "mm"),
scale = "bp", commas = TRUE, sequence = TRUE,
boxWidth = 0.5, axis = "x", at = NULL,
tcl = 0.5, x, y, length,
just = c("left", "top"),
default.units = "inches", params = NULL, ...) {
# =========================================================================
# FUNCTIONS
# =========================================================================
## Define a function that catches errors for plotGenomeLabel
errorcheck_plotGenomeLabel <- function(scale, ticks, object, axis) {
## Check that scale is an appropriate value
if (!scale %in% c("bp", "Kb", "Mb")) {
stop("Invalid \'scale\'. Options are \'bp\', \'Kb\', or \'Mb\'.",
call. = FALSE
)
}
if (!is.null(ticks)) {
## Can't have ticks if label is genome assembly for manhattan plot
if (is.null(object$chrom)) {
stop("Cannot add tick marks to a genome label of entire ",
"genome assembly.", call. = FALSE)
}
## Make sure ticks fall within the chromstart to chromend range
if (range(ticks)[1] < object$chromstart |
range(ticks)[2] > object$chromend) {
stop("Given tick locations do not fall within ",
"the genomic range.",
call. = FALSE
)
}
}
if (!axis %in% c("x", "y")) {
stop("Invalid \'axis\'. Options are \'x\' or \'y\'.", call. = FALSE)
}
}
# =========================================================================
# PARSE PARAMETERS
# =========================================================================
genomeLabelInternal <- parseParams(
params = params,
defaultArgs = formals(eval(match.call()[[1]])),
declaredArgs = lapply(match.call()[-1], eval.parent, n = 2),
class = "genomeLabelInternal"
)
## Parsing for "space" from input Manhattan plot from annoGenomeLabel
additionalParams <- list(...)
if ("space" %in% names(additionalParams)) {
genomeLabelInternal$space <- additionalParams$space
}
## Assign "gp"
genomeLabelInternal$gp <- gpar(
fontsize = genomeLabelInternal$fontsize,
col = genomeLabelInternal$linecolor,
fontcolor = genomeLabelInternal$fontcolor,
lineend = "butt"
)
genomeLabelInternal$gp <- setGP(
gpList = genomeLabelInternal$gp,
params = genomeLabelInternal, ...
)
## Justification
genomeLabelInternal$just <-
justConversion(genomeLabelInternal$just)
# =========================================================================
# INITIALIZE OBJECT
# =========================================================================
genomeLabel <- structure(list(
chrom = genomeLabelInternal$chrom,
chromstart = genomeLabelInternal$chromstart,
chromend = genomeLabelInternal$chromend,
assembly = genomeLabelInternal$assembly,
x = genomeLabelInternal$x,
y = genomeLabelInternal$y,
width = NULL, height = NULL,
just = genomeLabelInternal$just,
grobs = NULL
), class = "genomeLabel")
# =========================================================================
# CATCH ERRORS
# =========================================================================
if (is.null(genomeLabel$x)) stop("argument \"x\" is missing, ",
"with no default.", call. = FALSE)
if (is.null(genomeLabel$y)) stop("argument \"y\" is missing, ",
"with no default.", call. = FALSE)
if (is.null(genomeLabel$chrom)) stop("argument \"chrom\" is missing, ",
"with no default.", call. = FALSE)
if (is.null(genomeLabelInternal$length)) {
stop("argument \"length\" is missing, ",
"with no default.",
call. = FALSE
)
}
if (base::length(genomeLabel$chrom) == 1) {
if (is.null(genomeLabel$chromstart)) stop("argument \"chromstart\" ",
"is missing, with no ",
"default.", call. = FALSE)
if (is.null(genomeLabel$chromend)) stop("argument \"chromend\" ",
"is missing, with no ",
"default.", call. = FALSE)
} else {
if (is.null(genomeLabelInternal$space)) {
genomeLabelInternal$space <- 0.01
}
}
check_page(error = paste("Cannot plot a genome label without",
"a `plotgardener` page."))
errorcheck_plotGenomeLabel(
scale = genomeLabelInternal$scale,
ticks = genomeLabelInternal$at,
object = genomeLabel,
axis = genomeLabelInternal$axis
)
# =========================================================================
# PARSE ASSEMBLY
# =========================================================================
genomeLabel$assembly <-
parseAssembly(assembly = genomeLabel$assembly)
# =========================================================================
# PARSE UNITS
# =========================================================================
genomeLabel$x <- misc_defaultUnits(value = genomeLabel$x,
name = "x",
default.units =
genomeLabelInternal$default.units)
genomeLabel$y <- misc_defaultUnits(
value = genomeLabel$y,
name = "y",
default.units = genomeLabelInternal$default.units)
genomeLabelInternal$length <- misc_defaultUnits(
value = genomeLabelInternal$length,
name = "length",
default.units = genomeLabelInternal$default.units)
genomeLabelInternal$margin <- misc_defaultUnits(
value = genomeLabelInternal$margin,
name = "margin",
default.units = genomeLabelInternal$default.units)
# =========================================================================
# LABEL DEPTH
# =========================================================================
genomeLabelInternal$margin <-
convertHeight(genomeLabelInternal$margin,
unitTo = get("page_units", envir = pgEnv)
)
genomeLabelInternal$tgH <- convertHeight(heightDetails(textGrob(
label = genomeLabelInternal$scale,
x = 0.5, y = 0.5,
default.units = "npc",
gp = genomeLabelInternal$gp
)),
unitTo = get("page_units", envir = pgEnv)
)
if (!is.null(genomeLabelInternal$at)) {
genomeLabelInternal$tick_height <-
genomeLabelInternal$tgH * (genomeLabelInternal$tcl)
genomeLabelInternal$depth <-
convertHeight(genomeLabelInternal$tgH +
genomeLabelInternal$tick_height +
0.5 * genomeLabelInternal$tgH +
genomeLabelInternal$margin,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
} else {
genomeLabelInternal$tick_height <- NULL
genomeLabelInternal$depth <-
convertHeight(genomeLabelInternal$tgH +
genomeLabelInternal$margin,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
}
# =========================================================================
# GENOME LABEL FOR SINGLE CHROMOSOME
# =========================================================================
if (base::length(genomeLabel$chrom) == 1){
vp_name <- plotChromGenomeLabel(genomeLabel = genomeLabel,
genomeLabelInternal = genomeLabelInternal,
...)
} else {
# =========================================================================
# GENOME LABEL FOR MANHATTAN PLOT
# =========================================================================
vp_name <- plotManhattanGenomeLabel(genomeLabel = genomeLabel,
genomeLabelInternal = genomeLabelInternal)
}
# =========================================================================
# ASSIGN GROBS TO OBJECT
# =========================================================================
genomeLabel$grobs <- get("genomeLabel_grobs", envir = pgEnv)
grid.draw(genomeLabel$grobs)
# =========================================================================
# ASSIGN DIMENSIONS BASED ON AXIS
# =========================================================================
genomeLabel$width <- genomeLabelInternal$length
genomeLabel$height <- genomeLabelInternal$depth
if (genomeLabelInternal$axis == "y") {
genomeLabel$width <- genomeLabelInternal$depth
genomeLabel$height <- genomeLabelInternal$length
}
# =========================================================================
# RETURN OBJECT
# =========================================================================
message("genomeLabel[", vp_name, "]")
invisible(genomeLabel)
}
# Plots a standard genome label for a single chromosomal region
# @param genomeLabel genomeLabel object from plotGenomeLabel
# @param genomeLabelInternal genomeLabelInternal object
# from plotGenomeLabel
plotChromGenomeLabel <- function(genomeLabel,
genomeLabelInternal, ...){
# =========================================================================
# FUNCTIONS
# =========================================================================
## Define a function that adds commas to chromstart/chromend labels
comma_labels <- function(object, commas, fact, ...) {
digits <- list(...)$digits
if (is.null(digits)){
if (fact == 1){
digits <- rep(0, 2)
} else {
digits <- rep(1, 2)
}
}
if (length(digits) == 1){
digits <- rep(digits, 2)
}
roundedStart <- round(object$chromstart / fact, digits[1])
if ((roundedStart * fact) != object$chromstart) {
roundedStart <- paste0("~", roundedStart)
warning("Start label is rounded.", call. = FALSE)
}
roundedEnd <- round(object$chromend / fact, digits[2])
if ((roundedEnd * fact) != object$chromend) {
roundedEnd <- paste0("~", roundedEnd)
warning("End label is rounded.", call. = FALSE)
}
if (commas == TRUE) {
chromstartlabel <- formatC(roundedStart,
format = "f",
big.mark = ",", digits = digits[1]
)
chromendlabel <- formatC(roundedEnd,
format = "f",
big.mark = ",", digits = digits[2]
)
} else {
chromstartlabel <- roundedStart
chromendlabel <- roundedEnd
}
return(list(chromstartlabel, chromendlabel))
}
## Define a function that makes the label viewport
chrom_viewport <- function(object, length, depth, seqType,
vp_name, seqHeight, just, axis){
## No matter the orientation, convert to page units
convertedPageCoords <- convert_page(object = structure(list(
width = length,
height = unit(
depth,
get("page_units", envir = pgEnv)
),
x = object$x,
y = object$y
),
class = "genomeLabelInternal"
))
## Add "length" and "depth" into converted dimensions
convertedPageCoords$length <- convertedPageCoords$width
convertedPageCoords$depth <- convertedPageCoords$height
## Compile new dimensions into a new dummy viewport,
## where the default is along the x-axis
convertedViewport <- viewport(
width = convertedPageCoords$length,
height = convertedPageCoords$depth,
x = convertedPageCoords$x,
y = convertedPageCoords$y, just = just
)
if (!is.null(seqType)) {
## Get x and y coordinates of top left of what
## would be the entire viewport
topLeftViewport <- vp_topLeft(viewport = convertedViewport)
seq_height <- unit(seqHeight, get("page_units", envir = pgEnv))
## One vp for genome
vp1 <- viewport(
width = convertedPageCoords$width,
height = unit(depth, get("page_units", envir = pgEnv)),
x = topLeftViewport[[1]],
y = topLeftViewport[[2]] - seq_height,
just = c("left", "top"),
name = paste0(vp_name, "_01"),
xscale = c(object$chromstart, object$chromend),
yscale = c(0, depth)
)
## One vp for sequence
vp2 <- viewport(
width = convertedPageCoords$width,
height = seq_height,
x = topLeftViewport[[1]],
y = topLeftViewport[[2]],
just = c("left", "top"),
name = paste0(vp_name, "_02"),
clip = "on",
xscale = c(object$chromstart, object$chromend)
)
## Combine viewports into one
vp <- vpList(vp1, vp2)
} else {
if (axis == "y") {
## Update converted viewport for y-axis
convertedViewport <- viewport(
width = convertedPageCoords$depth,
height = convertedPageCoords$length,
x = convertedPageCoords$x,
y = convertedPageCoords$y,
just = just
)
## Get x and y coords of bottom right to rotate vp
bottomRightViewport <-
vp_bottomRight(viewport = convertedViewport)
## Make x-axis equivalent viewport and rotate into
## dimensions of given y-axis viewport
vp <- viewport(
width = convertedPageCoords$length,
height = convertedPageCoords$depth,
x = bottomRightViewport[[1]] -
convertedPageCoords$depth,
y = bottomRightViewport[[2]],
just = c("left", "top"),
name = vp_name,
xscale = c(object$chromstart, object$chromend),
yscale = c(0, depth),
angle = 90
)
} else {
vp <- viewport(
width = convertedPageCoords$width,
height = convertedPageCoords$height,
x = convertedPageCoords$x,
y = convertedPageCoords$y,
just = just,
name = vp_name,
xscale = c(object$chromstart, object$chromend),
yscale = c(0, depth)
)
}
}
return(vp)
}
## Define a function that makes tick, line, and text grobs for
## chrom/chromstart/chromend labels
chrom_grobs <- function(ticks, seqType, scale, chromLabel,
startLabel, endLabel, object, vp,
yaxis) {
margin <- convertHeight(object$margin,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
height <- convertHeight(object$depth,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
if (!is.null(seqType)) {
assign("genomeLabel_grobs", gTree(), envir = pgEnv)
chrom_vp <- vp[[1]]
if (!is.null(ticks)) {
tgH <- convertHeight(object$tgH,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
tick_height <- convertHeight(object$tick_height,
unitTo = get("page_units",
envir = pgEnv),
valueOnly = TRUE
)
x_coords <- ticks
y0_coord <- height
y1_coords <- rep(height - tick_height, length(ticks))
yLabel <- unit(height - (tick_height + margin), "native")
tickGrobs <- segmentsGrob(
x0 = x_coords,
y0 = rep(y0_coord, length(ticks)),
x1 = x_coords,
y1 = y1_coords,
vp = chrom_vp,
gp = object$gp,
default.units = "native"
)
line <- segmentsGrob(
x0 = unit(0, "npc"),
x1 = unit(1, "npc"),
y0 = y0_coord,
y1 = y0_coord,
vp = chrom_vp,
gp = object$gp,
default.units = "native"
)
object$gp$col <- object$gp$fontcolor
startLab <- textGrob(
label = paste(startLabel, scale),
x = unit(0, "npc"), y = yLabel,
just = c("left", "top"),
vp = chrom_vp,
gp = object$gp
)
endLab <- textGrob(
label = paste(endLabel, scale),
x = unit(1, "npc"), y = yLabel,
just = c("right", "top"),
vp = chrom_vp,
gp = object$gp
)
object$gp$fontface <- "bold"
chromLab <- textGrob(
label = chromLabel,
x = unit(0.5, "npc"), y = yLabel,
vp = chrom_vp,
gp = object$gp, just = c("center", "top")
)
assign("genomeLabel_grobs",
setChildren(get("genomeLabel_grobs", envir = pgEnv),
children = gList(
line, chromLab, startLab,
endLab, tickGrobs
)
),
envir = pgEnv
)
} else {
yLabel <- unit(height - margin, "native")
line <- segmentsGrob(
x0 = unit(0, "npc"), x1 = unit(1, "npc"),
y0 = height, y1 = height,
vp = chrom_vp,
gp = object$gp, default.units = "native"
)
object$gp$col <- object$gp$fontcolor
startLab <- textGrob(
label = paste(startLabel, scale, sep = " "),
x = unit(0, "npc"), y = yLabel,
vp = chrom_vp,
just = c("left", "top"),
gp = object$gp
)
endLab <- textGrob(
label = paste(endLabel, scale, sep = " "),
x = unit(1, "npc"), y = yLabel,
vp = chrom_vp,
just = c("right", "top"),
gp = object$gp
)
object$gp$fontface <- "bold"
chromLab <- textGrob(
label = chromLabel, x = unit(0.5, "npc"),
y = yLabel,
vp = chrom_vp,
gp = object$gp,
just = c("center", "top")
)
assign("genomeLabel_grobs",
setChildren(get("genomeLabel_grobs", envir = pgEnv),
children = gList(
line, chromLab,
startLab, endLab
)
),
envir = pgEnv
)
}
} else {
assign("genomeLabel_grobs", gTree(vp = vp), envir = pgEnv)
if (!is.null(ticks)) {
tgH <- convertHeight(object$tgH,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
tick_height <- convertHeight(object$tick_height,
unitTo = get("page_units",
envir = pgEnv),
valueOnly = TRUE
)
x_coords <- ticks
if (yaxis == TRUE) {
y0_coord <- 0
y1_coords <- rep(tick_height, length(ticks))
yLabel <- unit(tick_height + margin, "native")
tickGrobs <- segmentsGrob(
x0 = x_coords,
y0 = rep(y0_coord, length(ticks)),
x1 = x_coords, y1 = y1_coords,
gp = object$gp, default.units = "native"
)
line <- segmentsGrob(
x0 = unit(0, "npc"), x1 = unit(1, "npc"),
y0 = y0_coord, y1 = y0_coord,
gp = object$gp, default.units = "native"
)
object$gp$col <- object$gp$fontcolor
startLab <- textGrob(
label = paste(startLabel, scale),
x = unit(0, "npc"), y = yLabel,
just = c("left", "bottom"),
gp = object$gp
)
endLab <- textGrob(
label = paste(endLabel, scale),
x = unit(1, "npc"), y = yLabel,
just = c("right", "bottom"),
gp = object$gp
)
object$gp$fontface <- "bold"
chromLab <- textGrob(
label = chromLabel,
x = unit(0.5, "npc"), y = yLabel,
gp = object$gp, just = c("center", "bottom")
)
} else {
y0_coord <- height
y1_coords <- rep(height - tick_height, length(ticks))
yLabel <- unit(height - (tick_height + margin), "native")
tickGrobs <- segmentsGrob(
x0 = x_coords,
y0 = rep(y0_coord, length(ticks)),
x1 = x_coords, y1 = y1_coords,
gp = object$gp, default.units = "native"
)
line <- segmentsGrob(
x0 = unit(0, "npc"), x1 = unit(1, "npc"),
y0 = y0_coord, y1 = y0_coord,
gp = object$gp, default.units = "native"
)
object$gp$col <- object$gp$fontcolor
startLab <- textGrob(
label = paste(startLabel, scale),
x = unit(0, "npc"),
y = unit(tgH + 0.25 * tgH, "native"),
just = c("left", "top"),
gp = object$gp
)
endLab <- textGrob(
label = paste(endLabel, scale),
x = unit(1, "npc"),
y = unit(tgH + 0.25 * tgH, "native"),
just = c("right", "top"),
gp = object$gp
)
object$gp$fontface <- "bold"
chromLab <- textGrob(
label = chromLabel, x = unit(0.5, "npc"),
y = unit(tgH + 0.25 * tgH, "native"),
gp = object$gp, just = c("center", "top")
)
}
assign("genomeLabel_grobs",
setChildren(get("genomeLabel_grobs", envir = pgEnv),
children = gList(
line, chromLab, startLab,
endLab, tickGrobs
)
),
envir = pgEnv
)
} else {
if (yaxis == TRUE) {
yLabel <- unit(margin, "native")
line <- segmentsGrob(
x0 = unit(0, "npc"), x1 = unit(1, "npc"),
y0 = unit(0, "npc"), y1 = unit(0, "npc"),
gp = object$gp
)
object$gp$col <- object$gp$fontcolor
startLab <- textGrob(
label = paste(startLabel, scale, sep = " "),
x = unit(0, "npc"), y = yLabel,
just = c("left", "bottom"),
gp = object$gp
)
endLab <- textGrob(
label = paste(endLabel, scale, sep = " "),
x = unit(1, "npc"), y = yLabel,
just = c("right", "bottom"),
gp = object$gp
)
object$gp$fontface <- "bold"
chromLab <- textGrob(
label = chromLabel, x = unit(0.5, "npc"),
y = yLabel,
gp = object$gp,
just = c("center", "bottom")
)
} else {
yLabel <- unit(height - margin, "native")
line <- segmentsGrob(
x0 = unit(0, "npc"), x1 = unit(1, "npc"),
y0 = height, y1 = height,
gp = object$gp, default.units = "native"
)
object$gp$col <- object$gp$fontcolor
startLab <- textGrob(
label = paste(startLabel, scale, sep = " "),
x = unit(0, "npc"), y = yLabel,
just = c("left", "top"),
gp = object$gp
)
endLab <- textGrob(
label = paste(endLabel, scale, sep = " "),
x = unit(1, "npc"), y = yLabel,
just = c("right", "top"),
gp = object$gp
)
object$gp$fontface <- "bold"
chromLab <- textGrob(
label = chromLabel, x = unit(0.5, "npc"),
y = yLabel,
gp = object$gp,
just = c("center", "top")
)
}
assign("genomeLabel_grobs",
setChildren(get("genomeLabel_grobs", envir = pgEnv),
children = gList(
line, chromLab,
startLab, endLab
)
),
envir = pgEnv
)
}
}
}
## Define a function that makes sequence grobs (boxes or letters)
seq_grobs <- function(object, seqHeight, seqType, assembly, chromLabel, vp,
boxWidth, gparParams) {
bsgenome <- eval(parse(text = paste0(as.name(object$assembly$BSgenome),
"::",
as.name(object$assembly$BSgenome))))
## Get sequence in that region
sequence <- strsplit(as.character(BSgenome::getSeq(
bsgenome,
GenomicRanges::GRanges(
seqnames = chromLabel,
ranges = IRanges::IRanges(
start = object$chromstart,
end = object$chromend
)
)
)),
split = ""
)
## Make dataframe of sequence letter, position, and color
dfSequence <- data.frame(
"nucleotide" = unlist(sequence),
"pos" = seq(object$chromstart, object$chromend),
"col" = "grey"
)
## Make colors A = green, T = red, G = orange, C = blue
invisible(tryCatch(dfSequence[which(
dfSequence$nucleotide == "A"
), ]$col <- "#7CD95B",
error = function(e) {}
))
invisible(tryCatch(dfSequence[which(
dfSequence$nucleotide == "T"
), ]$col <- "#F1686C",
error = function(e) {}
))
invisible(tryCatch(dfSequence[which(
dfSequence$nucleotide == "G"
), ]$col <- "#FFDD12",
error = function(e) {}
))
invisible(tryCatch(dfSequence[which(
dfSequence$nucleotide == "C"
), ]$col <- "#5566FF",
error = function(e) {}
))
seq_vp <- vp[[2]]
## Make grobs based on seqType
if (seqType == "letters") {
seqGrobs <- textGrob(
label = dfSequence$nucleotide, x = dfSequence$pos,
y = unit(0.5, "npc"), just = "center",
vp = seq_vp,
default.units = "native",
gp = gpar(
col = dfSequence$col,
fontsize = gparParams$gp$fontsize - 2
)
)
} else if (seqType == "boxes") {
seqGrobs <- rectGrob(
x = dfSequence$pos, y = unit(1, "npc"),
width = boxWidth,
height = unit(
seqHeight - 0.05 * seqHeight,
get("page_units", envir = pgEnv)
),
just = c("center", "top"),
vp = seq_vp,
default.units = "native",
gp = gpar(col = NA, fill = dfSequence$col)
)
}
assign("genomeLabel_grobs",
addGrob(
gTree = get("genomeLabel_grobs", envir = pgEnv),
child = seqGrobs
),
envir = pgEnv
)
}
# =========================================================================
# COMMAS
# =========================================================================
## Determine scale of labels
if (genomeLabelInternal$scale == "bp") {
fact <- 1
}
if (genomeLabelInternal$scale == "Mb") {
fact <- 1000000
}
if (genomeLabelInternal$scale == "Kb") {
fact <- 1000
}
commaLabels <- comma_labels(
object = genomeLabel,
commas = genomeLabelInternal$commas,
fact = fact, ...
)
chromstartlabel <- commaLabels[[1]]
chromendlabel <- commaLabels[[2]]
# =========================================================================
# NUCLEOTIDE SEQUENCE INFORMATION
# =========================================================================
seq_height <- heightDetails(textGrob(
label = "A",
x = 0.5, y = 0.5,
default.units = "npc",
gp = gpar(fontsize = genomeLabelInternal$gp$fontsize - 2)
))
seq_height <- convertHeight(seq_height + 0.05 * seq_height,
unitTo = get("page_units", envir = pgEnv)
)
seqType <- NULL
if (genomeLabelInternal$sequence == TRUE) {
if (genomeLabelInternal$axis == "x") {
labelWidth <- convertWidth(genomeLabelInternal$length,
unitTo = "inches",
valueOnly = TRUE
)
bpWidth <- convertWidth(widthDetails(textGrob(
label = "A",
x = 0.5, y = 0.5,
default.units = "npc",
gp = gpar(fontsize = genomeLabelInternal$gp$fontsize - 2)
)),
unitTo = "inches",
valueOnly = TRUE
)
seqRange <- genomeLabel$chromend - genomeLabel$chromstart
seqWidth <- bpWidth * seqRange
if (seqWidth <= labelWidth) {
seqType <- "letters"
} else if (seqWidth / labelWidth <= 9) {
seqType <- "boxes"
}
}
}
## Check for BSgenome packages and reset seqType if necessary
if (!is.null(seqType)) {
if (!is.null(genomeLabel$assembly$BSgenome)) {
if (!requireNamespace(genomeLabel$assembly$BSgenome,
quietly = TRUE)){
bsChecks <- FALSE
warning("`", genomeLabel$assembly$BSgenome,
"` not available. ",
"Sequence information will not be displayed.",
call. = FALSE)
} else {
bsChecks <- TRUE
}
if (bsChecks == FALSE) {
seqType <- NULL
}
} else {
warning("No `BSgenome` package found for the input assembly. ",
"Sequence information cannot be displayed.", call. = FALSE)
seqType <- NULL
}
}
if (!is.null(seqType)) {
seq_height <- convertHeight(seq_height,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
genomeLabelInternal$depth <- unit(
genomeLabelInternal$depth + seq_height,
get("page_units", envir = pgEnv)
)
} else {
genomeLabelInternal$depth <- unit(
genomeLabelInternal$depth,
get("page_units", envir = pgEnv)
)
}
# =========================================================================
# VIEWPORTS
# =========================================================================
## Name viewport
currentViewports <- current_viewports()
vp_name <- paste0(
"genomeLabel",
base::length(grep(
pattern = "genomeLabel",
x = currentViewports
)) + 1
)
## Make viewport
vp <- chrom_viewport(
object = genomeLabel,
length = genomeLabelInternal$length,
depth = genomeLabelInternal$depth,
seqType = seqType,
seqHeight = seq_height,
vp_name = vp_name, just = genomeLabel$just,
axis = genomeLabelInternal$axis
)
# =========================================================================
# GROBS AND GTREE
# =========================================================================
chrom_grobs(
ticks = genomeLabelInternal$at,
seqType = seqType,
scale = genomeLabelInternal$scale,
chromLabel = genomeLabel$chrom,
startLabel = chromstartlabel, endLabel = chromendlabel,
object = genomeLabelInternal, vp = vp,
yaxis = (genomeLabelInternal$axis == "y")
)
## Sequence grobs if applicable
if (!is.null(seqType)) {
seq_grobs(
object = genomeLabel, seqHeight = seq_height,
seqType = seqType, assembly = genomeLabel$assembly,
chromLabel = genomeLabel$chrom, vp = vp,
boxWidth = genomeLabelInternal$boxWidth,
gparParams = genomeLabelInternal
)
}
return(vp_name)
}
# Plots a genome label for a multi-chromosomal Manhattan plot
# @param genomeLabel genomeLabel object from plotGenomeLabel
# @param genomeLabelInternal genomeLabelInternal object
# from plotGenomeLabel
plotManhattanGenomeLabel <- function(genomeLabel, genomeLabelInternal){
# =========================================================================
# FUNCTIONS
# =========================================================================
## Define a function that makes the label viewport
manhattan_viewport <- function(object, length, depth,
vp_name, just, axis, space){
## Convert to page units
convertedPageCoords <- convert_page(object = structure(list(
width = length,
height = unit(
depth,
get("page_units", envir = pgEnv)
),
x = object$x,
y = object$y
),
class = "genomeLabelInternal"
))
## Add "length" and "depth" into converted dimensions
convertedPageCoords$length <- convertedPageCoords$width
convertedPageCoords$depth <- convertedPageCoords$height
## Compile new dimensions into a new dummy viewport,
## where the default is along the x-axis
convertedViewport <- viewport(
width = convertedPageCoords$length,
height = convertedPageCoords$depth,
x = convertedPageCoords$x,
y = convertedPageCoords$y, just = just
)
## Get assembly data
if (is(object$assembly$TxDb, "TxDb")) {
txdbChecks <- TRUE
} else {
if (!requireNamespace(object$assembly$TxDb, quietly = TRUE)){
txdbChecks <- FALSE
warning("`", object$assembly$TxDb, "` not available. Please ",
"install to label genome.", call. = FALSE)
} else {
txdbChecks <- TRUE
}
}
if (txdbChecks == TRUE) {
if (is(object$assembly$TxDb, "TxDb")) {
tx_db <- object$assembly$TxDb
} else {
tx_db <- eval(parse(text = paste0(as.name(object$assembly$TxDb),
"::",
as.name(object$assembly$TxDb))))
}
assembly_data <- as.data.frame(setDT(as.data.frame(
GenomeInfoDb::seqlengths(tx_db)
),
keep.rownames = TRUE
))
colnames(assembly_data) <- c("chrom", "length")
assembly_data <- assembly_data[which(assembly_data[, "chrom"] %in%
object$chrom), ]
## get the offsets based on spacer for the assembly
offsetAssembly <- spaceChroms(
assemblyData = assembly_data,
space = space
)
cumsums <- cumsum(as.numeric(assembly_data[, "length"]))
spacer <- cumsums[length(cumsum(
as.numeric(assembly_data[, "length"])
))] * space
xscale <- c(0, max(offsetAssembly[, "end"]) + spacer)
} else {
xscale <- c(0, 1)
}
if (axis == "y") {
## Update converted viewport for y-axis
convertedViewport <- viewport(
width = convertedPageCoords$depth,
height = convertedPageCoords$length,
x = convertedPageCoords$x,
y = convertedPageCoords$y, just = just
)
## Get x and y coordinates of bottom right to rotate
## x-axis viewport
bottomRightViewport <-
vp_bottomRight(viewport = convertedViewport)
## Make x-axis equivalent viewport and rotate into
## dimensions of given y-axis viewport
vp <- viewport(
width = convertedPageCoords$length,
height = convertedPageCoords$depth,
x = bottomRightViewport[[1]] - convertedPageCoords$depth,
y = bottomRightViewport[[2]],
just = c("left", "top"),
name = vp_name,
xscale = c(object$chromstart, object$chromend),
yscale = c(0, depth),
angle = 90
)
} else {
vp <- viewport(
width = convertedPageCoords$width,
height = convertedPageCoords$height,
x = convertedPageCoords$x,
y = convertedPageCoords$y,
just = just,
name = vp_name,
xscale = xscale,
yscale = c(0, depth)
)
}
return(vp)
}
## Define a function that makes line and text grobs for whole assembly
## labels in Manhattan plots
genome_grobs <- function(object, vp, gp, space) {
## Initialize gTree
assign("genomeLabel_grobs", gTree(vp = vp), envir = pgEnv)
## Get assembly data
if (is(object$assembly$TxDb, "TxDb")) {
txdbChecks <- TRUE
} else {
if (!requireNamespace(object$assembly$TxDb, quietly = TRUE)){
txdbChecks <- FALSE
} else {
txdbChecks <- TRUE
}
}
if (txdbChecks == TRUE) {
if (is(object$assembly$TxDb, "TxDb")) {
tx_db <- object$assembly$TxDb
} else {
tx_db <- eval(parse(text =
paste0(as.name(object$assembly$TxDb),
"::",
as.name(object$assembly$TxDb))))
}
assembly_data <- as.data.frame(setDT(as.data.frame(
GenomeInfoDb::seqlengths(tx_db)
),
keep.rownames = TRUE
))
colnames(assembly_data) <- c("chrom", "length")
assembly_data <- assembly_data[which(assembly_data[, "chrom"] %in%
object$chrom), ]
## Get the offsets based on spacer for the assembly
offsetAssembly <- spaceChroms(
assemblyData = assembly_data,
space = space
)
## Get the centers of each chrom
chromCenters <- (offsetAssembly[, "start"] +
offsetAssembly[, "end"]) / 2
margin <- convertHeight(object$margin,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
line <- segmentsGrob(
x0 = unit(0, "npc"), x1 = unit(1, "npc"),
y0 = unit(1, "npc"), y1 = unit(1, "npc"), gp = gp
)
gp$col <- gp$fontcolor
labels <- textGrob(
label = gsub("chr", "", offsetAssembly[, 1]),
x = chromCenters,
y = unit(1, "npc") - unit(margin, "native"),
just = c("center", "top"),
gp = gp,
default.units = "native"
)
assign("genomeLabel_grobs",
setChildren(get("genomeLabel_grobs", envir = pgEnv),
children = gList(line, labels)
),
envir = pgEnv
)
}
}
# =========================================================================
# VIEWPORTS
# =========================================================================
## Name viewport
currentViewports <- current_viewports()
vp_name <- paste0(
"genomeLabel",
base::length(grep(
pattern = "genomeLabel",
x = currentViewports
)) + 1
)
## Make viewport
vp <- manhattan_viewport(
object = genomeLabel,
length = genomeLabelInternal$length,
depth = genomeLabelInternal$depth,
vp_name = vp_name, just = genomeLabel$just,
axis = genomeLabelInternal$axis,
space = genomeLabelInternal$space
)
# =========================================================================
# GROBS AND GTREE
# =========================================================================
genome_grobs(
object = genomeLabelInternal, vp = vp,
gp = genomeLabelInternal$gp,
space = genomeLabelInternal$space
)
return(vp_name)
}
PhanstielLab/plotgardener documentation built on July 1, 2024, 7: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 plotManhattanGenomeLabel plotChromGenomeLabel plotGenomeLabel
Documented in plotGenomeLabel
#' Plot genomic coordinates along the x or y-axis of a plotgardener plot
#'
#' @usage plotGenomeLabel(
#' chrom,
#' chromstart = NULL,
#' chromend = NULL,
#' assembly = "hg38",
#' fontsize = 10,
#' fontcolor = "black",
#' linecolor = "black",
#' margin = unit(1, "mm"),
#' scale = "bp",
#' commas = TRUE,
#' sequence = TRUE,
#' boxWidth = 0.5,
#' axis = "x",
#' at = NULL,
#' tcl = 0.5,
#' x,
#' y,
#' length,
#' just = c("left", "top"),
#' default.units = "inches",
#' params = NULL,
#' ...
#' )
#'
#' @param chrom Chromosome of genome label, as a string,
#' or a character vector of chromosomes for a whole genome Manhattan plot.
#' @param chromstart Integer start of genome label.
#' @param chromend Integer end of genome label.
#' @param assembly Default genome assembly as a string or a
#' \link[plotgardener]{assembly} object.
#' @param fontsize A numeric specifying text fontsize in points.
#' Default value is \code{fontsize = 10}.
#' @param fontcolor A character value indicating the color for text.
#' Default value is \code{fontcolor = "black"}.
#' @param linecolor A character value indicating the color of
#' the genome label axis. Default value is \code{linecolor = "black"}.
#' @param margin A numeric or unit vector specifying space between axis
#' and coordinate labels. Default value is \code{margin = unit(1, "mm")},
#' @param scale A character value indicating the scale of the coordinates
#' along the genome label. Default value is \code{scale = "bp"}. Options are:
#' \itemize{
#' \item{\code{"bp"}: }{base pairs.}
#' \item{\code{"Kb"}: }{kilobase pairs. 1 kilobase pair is equal to
#' 1000 base pairs.}
#' \item{\code{"Mb"}: }{megabase pairs. 1 megabase pair is equal to
#' 1000000 base pairs.}
#' }
#' @param commas A logical value indicating whether to include commas in
#' start and stop labels. Default value is \code{commas = TRUE}.
#' @param sequence A logical value indicating whether to include sequence
#' information above the label of an x-axis (only at appropriate resolutions).
#' @param boxWidth A numeric value indicating the width of the boxes
#' representing sequence information at appropriate resolutions.
#' Default value is \code{boxWidth = 0.5}.
#' @param axis A character value indicating along which axis to
#' add genome label. Sequence information will not be displayed along a y-axis.
#' Default value is \code{axis = "x"}.
#' Options are:
#' \itemize{
#' \item{\code{"x"}: }{Genome label will be plotted along the x-axis.}
#' \item{\code{"y"}: }{Genome label will be plotted along the y-axis.
#' This is typically used for a square Hi-C plot made with
#' \code{plotHicSquare}.}
#' }
#' @param at A numeric vector of x-value locations for tick marks.
#' @param tcl A numeric specifying the length of tickmarks as a
#' fraction of text height. Default value is \code{tcl = 0.5}.
#' @param x A numeric or unit object specifying genome label x-location.
#' @param y A numeric, unit object, or character containing a "b"
#' combined with a numeric value specifying genome label y-location.
#' The character value will
#' place the genome label y relative to the bottom of the most recently
#' plotted plot according to the units of the plotgardener page.
#' @param length A numeric or unit object specifying length of
#' genome label axis.
#' @param just Justification of genome label 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}, or \code{length} are only given as numerics.
#' Default value is \code{default.units = "inches"}.
#' @param params An optional \link[plotgardener]{pgParams} object
#' containing relevant function parameters.
#' @param ... Additional grid graphical parameters or digit specifications.
#' See \link[grid]{gpar} and \link[base]{formatC}.
#'
#' @return Returns a \code{genomeLabel} 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")
#' library("BSgenome.Hsapiens.UCSC.hg19")
#'
#' ## Create page
#' pageCreate(width = 5, height = 3, default.units = "inches")
#'
#' ## Plot and place gene track on page
#' genesPlot <- plotGenes(
#' chrom = "chr8",
#' chromstart = 1000000, chromend = 2000000,
#' assembly = "hg19", fill = c("grey", "grey"),
#' fontcolor = c("grey", "grey"),
#' x = 0.5, y = 0.25, width = 4, height = 1,
#' just = c("left", "top"),
#' default.units = "inches"
#' )
#'
#' ## Plot x-axis genome labels at different scales
#' plotGenomeLabel(
#' chrom = "chr8",
#' chromstart = 1000000, chromend = 2000000,
#' assembly = "hg19",
#' scale = "Mb",
#' x = 0.5, y = 1.25, length = 4, just = c("left", "top"),
#' default.units = "inches"
#' )
#' plotGenomeLabel(
#' chrom = "chr8",
#' chromstart = 1000000, chromend = 2000000,
#' assembly = "hg19",
#' scale = "Kb",
#' x = 0.5, y = 1.5, length = 4, just = c("left", "top"),
#' default.units = "inches"
#' )
#' plotGenomeLabel(
#' chrom = "chr8",
#' chromstart = 1000000, chromend = 2000000,
#' assembly = "hg19",
#' scale = "bp",
#' x = 0.5, y = 1.75, length = 4, just = c("left", "top"),
#' default.units = "inches"
#' )
#'
#' ## Plot a different genomic label region, zooming in enough
#' ## to see base pairs
#' plotGenomeLabel(
#' chrom = "chr8",
#' chromstart = 1000000, chromend = 1000050,
#' assembly = "hg19",
#' x = 0.25, y = 2.2, length = 4.5
#' )
#' plotGenomeLabel(
#' chrom = "chr8",
#' chromstart = 1000000, chromend = 1000020,
#' assembly = "hg19",
#' x = 0, y = 2.6, length = 5
#' )
#'
#' ## Hide page guides
#' pageGuideHide()
#' @export
plotGenomeLabel <- function(chrom, chromstart = NULL, chromend = NULL,
assembly = "hg38", fontsize = 10,
fontcolor = "black", linecolor = "black",
margin = unit(1, "mm"),
scale = "bp", commas = TRUE, sequence = TRUE,
boxWidth = 0.5, axis = "x", at = NULL,
tcl = 0.5, x, y, length,
just = c("left", "top"),
default.units = "inches", params = NULL, ...) {
# =========================================================================
# FUNCTIONS
# =========================================================================
## Define a function that catches errors for plotGenomeLabel
errorcheck_plotGenomeLabel <- function(scale, ticks, object, axis) {
## Check that scale is an appropriate value
if (!scale %in% c("bp", "Kb", "Mb")) {
stop("Invalid \'scale\'. Options are \'bp\', \'Kb\', or \'Mb\'.",
call. = FALSE
)
}
if (!is.null(ticks)) {
## Can't have ticks if label is genome assembly for manhattan plot
if (is.null(object$chrom)) {
stop("Cannot add tick marks to a genome label of entire ",
"genome assembly.", call. = FALSE)
}
## Make sure ticks fall within the chromstart to chromend range
if (range(ticks)[1] < object$chromstart |
range(ticks)[2] > object$chromend) {
stop("Given tick locations do not fall within ",
"the genomic range.",
call. = FALSE
)
}
}
if (!axis %in% c("x", "y")) {
stop("Invalid \'axis\'. Options are \'x\' or \'y\'.", call. = FALSE)
}
}
# =========================================================================
# PARSE PARAMETERS
# =========================================================================
genomeLabelInternal <- parseParams(
params = params,
defaultArgs = formals(eval(match.call()[[1]])),
declaredArgs = lapply(match.call()[-1], eval.parent, n = 2),
class = "genomeLabelInternal"
)
## Parsing for "space" from input Manhattan plot from annoGenomeLabel
additionalParams <- list(...)
if ("space" %in% names(additionalParams)) {
genomeLabelInternal$space <- additionalParams$space
}
## Assign "gp"
genomeLabelInternal$gp <- gpar(
fontsize = genomeLabelInternal$fontsize,
col = genomeLabelInternal$linecolor,
fontcolor = genomeLabelInternal$fontcolor,
lineend = "butt"
)
genomeLabelInternal$gp <- setGP(
gpList = genomeLabelInternal$gp,
params = genomeLabelInternal, ...
)
## Justification
genomeLabelInternal$just <-
justConversion(genomeLabelInternal$just)
# =========================================================================
# INITIALIZE OBJECT
# =========================================================================
genomeLabel <- structure(list(
chrom = genomeLabelInternal$chrom,
chromstart = genomeLabelInternal$chromstart,
chromend = genomeLabelInternal$chromend,
assembly = genomeLabelInternal$assembly,
x = genomeLabelInternal$x,
y = genomeLabelInternal$y,
width = NULL, height = NULL,
just = genomeLabelInternal$just,
grobs = NULL
), class = "genomeLabel")
# =========================================================================
# CATCH ERRORS
# =========================================================================
if (is.null(genomeLabel$x)) stop("argument \"x\" is missing, ",
"with no default.", call. = FALSE)
if (is.null(genomeLabel$y)) stop("argument \"y\" is missing, ",
"with no default.", call. = FALSE)
if (is.null(genomeLabel$chrom)) stop("argument \"chrom\" is missing, ",
"with no default.", call. = FALSE)
if (is.null(genomeLabelInternal$length)) {
stop("argument \"length\" is missing, ",
"with no default.",
call. = FALSE
)
}
if (base::length(genomeLabel$chrom) == 1) {
if (is.null(genomeLabel$chromstart)) stop("argument \"chromstart\" ",
"is missing, with no ",
"default.", call. = FALSE)
if (is.null(genomeLabel$chromend)) stop("argument \"chromend\" ",
"is missing, with no ",
"default.", call. = FALSE)
} else {
if (is.null(genomeLabelInternal$space)) {
genomeLabelInternal$space <- 0.01
}
}
check_page(error = paste("Cannot plot a genome label without",
"a `plotgardener` page."))
errorcheck_plotGenomeLabel(
scale = genomeLabelInternal$scale,
ticks = genomeLabelInternal$at,
object = genomeLabel,
axis = genomeLabelInternal$axis
)
# =========================================================================
# PARSE ASSEMBLY
# =========================================================================
genomeLabel$assembly <-
parseAssembly(assembly = genomeLabel$assembly)
# =========================================================================
# PARSE UNITS
# =========================================================================
genomeLabel$x <- misc_defaultUnits(value = genomeLabel$x,
name = "x",
default.units =
genomeLabelInternal$default.units)
genomeLabel$y <- misc_defaultUnits(
value = genomeLabel$y,
name = "y",
default.units = genomeLabelInternal$default.units)
genomeLabelInternal$length <- misc_defaultUnits(
value = genomeLabelInternal$length,
name = "length",
default.units = genomeLabelInternal$default.units)
genomeLabelInternal$margin <- misc_defaultUnits(
value = genomeLabelInternal$margin,
name = "margin",
default.units = genomeLabelInternal$default.units)
# =========================================================================
# LABEL DEPTH
# =========================================================================
genomeLabelInternal$margin <-
convertHeight(genomeLabelInternal$margin,
unitTo = get("page_units", envir = pgEnv)
)
genomeLabelInternal$tgH <- convertHeight(heightDetails(textGrob(
label = genomeLabelInternal$scale,
x = 0.5, y = 0.5,
default.units = "npc",
gp = genomeLabelInternal$gp
)),
unitTo = get("page_units", envir = pgEnv)
)
if (!is.null(genomeLabelInternal$at)) {
genomeLabelInternal$tick_height <-
genomeLabelInternal$tgH * (genomeLabelInternal$tcl)
genomeLabelInternal$depth <-
convertHeight(genomeLabelInternal$tgH +
genomeLabelInternal$tick_height +
0.5 * genomeLabelInternal$tgH +
genomeLabelInternal$margin,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
} else {
genomeLabelInternal$tick_height <- NULL
genomeLabelInternal$depth <-
convertHeight(genomeLabelInternal$tgH +
genomeLabelInternal$margin,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
}
# =========================================================================
# GENOME LABEL FOR SINGLE CHROMOSOME
# =========================================================================
if (base::length(genomeLabel$chrom) == 1){
vp_name <- plotChromGenomeLabel(genomeLabel = genomeLabel,
genomeLabelInternal = genomeLabelInternal,
...)
} else {
# =========================================================================
# GENOME LABEL FOR MANHATTAN PLOT
# =========================================================================
vp_name <- plotManhattanGenomeLabel(genomeLabel = genomeLabel,
genomeLabelInternal = genomeLabelInternal)
}
# =========================================================================
# ASSIGN GROBS TO OBJECT
# =========================================================================
genomeLabel$grobs <- get("genomeLabel_grobs", envir = pgEnv)
grid.draw(genomeLabel$grobs)
# =========================================================================
# ASSIGN DIMENSIONS BASED ON AXIS
# =========================================================================
genomeLabel$width <- genomeLabelInternal$length
genomeLabel$height <- genomeLabelInternal$depth
if (genomeLabelInternal$axis == "y") {
genomeLabel$width <- genomeLabelInternal$depth
genomeLabel$height <- genomeLabelInternal$length
}
# =========================================================================
# RETURN OBJECT
# =========================================================================
message("genomeLabel[", vp_name, "]")
invisible(genomeLabel)
}
# Plots a standard genome label for a single chromosomal region
# @param genomeLabel genomeLabel object from plotGenomeLabel
# @param genomeLabelInternal genomeLabelInternal object
# from plotGenomeLabel
plotChromGenomeLabel <- function(genomeLabel,
genomeLabelInternal, ...){
# =========================================================================
# FUNCTIONS
# =========================================================================
## Define a function that adds commas to chromstart/chromend labels
comma_labels <- function(object, commas, fact, ...) {
digits <- list(...)$digits
if (is.null(digits)){
if (fact == 1){
digits <- rep(0, 2)
} else {
digits <- rep(1, 2)
}
}
if (length(digits) == 1){
digits <- rep(digits, 2)
}
roundedStart <- round(object$chromstart / fact, digits[1])
if ((roundedStart * fact) != object$chromstart) {
roundedStart <- paste0("~", roundedStart)
warning("Start label is rounded.", call. = FALSE)
}
roundedEnd <- round(object$chromend / fact, digits[2])
if ((roundedEnd * fact) != object$chromend) {
roundedEnd <- paste0("~", roundedEnd)
warning("End label is rounded.", call. = FALSE)
}
if (commas == TRUE) {
chromstartlabel <- formatC(roundedStart,
format = "f",
big.mark = ",", digits = digits[1]
)
chromendlabel <- formatC(roundedEnd,
format = "f",
big.mark = ",", digits = digits[2]
)
} else {
chromstartlabel <- roundedStart
chromendlabel <- roundedEnd
}
return(list(chromstartlabel, chromendlabel))
}
## Define a function that makes the label viewport
chrom_viewport <- function(object, length, depth, seqType,
vp_name, seqHeight, just, axis){
## No matter the orientation, convert to page units
convertedPageCoords <- convert_page(object = structure(list(
width = length,
height = unit(
depth,
get("page_units", envir = pgEnv)
),
x = object$x,
y = object$y
),
class = "genomeLabelInternal"
))
## Add "length" and "depth" into converted dimensions
convertedPageCoords$length <- convertedPageCoords$width
convertedPageCoords$depth <- convertedPageCoords$height
## Compile new dimensions into a new dummy viewport,
## where the default is along the x-axis
convertedViewport <- viewport(
width = convertedPageCoords$length,
height = convertedPageCoords$depth,
x = convertedPageCoords$x,
y = convertedPageCoords$y, just = just
)
if (!is.null(seqType)) {
## Get x and y coordinates of top left of what
## would be the entire viewport
topLeftViewport <- vp_topLeft(viewport = convertedViewport)
seq_height <- unit(seqHeight, get("page_units", envir = pgEnv))
## One vp for genome
vp1 <- viewport(
width = convertedPageCoords$width,
height = unit(depth, get("page_units", envir = pgEnv)),
x = topLeftViewport[[1]],
y = topLeftViewport[[2]] - seq_height,
just = c("left", "top"),
name = paste0(vp_name, "_01"),
xscale = c(object$chromstart, object$chromend),
yscale = c(0, depth)
)
## One vp for sequence
vp2 <- viewport(
width = convertedPageCoords$width,
height = seq_height,
x = topLeftViewport[[1]],
y = topLeftViewport[[2]],
just = c("left", "top"),
name = paste0(vp_name, "_02"),
clip = "on",
xscale = c(object$chromstart, object$chromend)
)
## Combine viewports into one
vp <- vpList(vp1, vp2)
} else {
if (axis == "y") {
## Update converted viewport for y-axis
convertedViewport <- viewport(
width = convertedPageCoords$depth,
height = convertedPageCoords$length,
x = convertedPageCoords$x,
y = convertedPageCoords$y,
just = just
)
## Get x and y coords of bottom right to rotate vp
bottomRightViewport <-
vp_bottomRight(viewport = convertedViewport)
## Make x-axis equivalent viewport and rotate into
## dimensions of given y-axis viewport
vp <- viewport(
width = convertedPageCoords$length,
height = convertedPageCoords$depth,
x = bottomRightViewport[[1]] -
convertedPageCoords$depth,
y = bottomRightViewport[[2]],
just = c("left", "top"),
name = vp_name,
xscale = c(object$chromstart, object$chromend),
yscale = c(0, depth),
angle = 90
)
} else {
vp <- viewport(
width = convertedPageCoords$width,
height = convertedPageCoords$height,
x = convertedPageCoords$x,
y = convertedPageCoords$y,
just = just,
name = vp_name,
xscale = c(object$chromstart, object$chromend),
yscale = c(0, depth)
)
}
}
return(vp)
}
## Define a function that makes tick, line, and text grobs for
## chrom/chromstart/chromend labels
chrom_grobs <- function(ticks, seqType, scale, chromLabel,
startLabel, endLabel, object, vp,
yaxis) {
margin <- convertHeight(object$margin,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
height <- convertHeight(object$depth,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
if (!is.null(seqType)) {
assign("genomeLabel_grobs", gTree(), envir = pgEnv)
chrom_vp <- vp[[1]]
if (!is.null(ticks)) {
tgH <- convertHeight(object$tgH,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
tick_height <- convertHeight(object$tick_height,
unitTo = get("page_units",
envir = pgEnv),
valueOnly = TRUE
)
x_coords <- ticks
y0_coord <- height
y1_coords <- rep(height - tick_height, length(ticks))
yLabel <- unit(height - (tick_height + margin), "native")
tickGrobs <- segmentsGrob(
x0 = x_coords,
y0 = rep(y0_coord, length(ticks)),
x1 = x_coords,
y1 = y1_coords,
vp = chrom_vp,
gp = object$gp,
default.units = "native"
)
line <- segmentsGrob(
x0 = unit(0, "npc"),
x1 = unit(1, "npc"),
y0 = y0_coord,
y1 = y0_coord,
vp = chrom_vp,
gp = object$gp,
default.units = "native"
)
object$gp$col <- object$gp$fontcolor
startLab <- textGrob(
label = paste(startLabel, scale),
x = unit(0, "npc"), y = yLabel,
just = c("left", "top"),
vp = chrom_vp,
gp = object$gp
)
endLab <- textGrob(
label = paste(endLabel, scale),
x = unit(1, "npc"), y = yLabel,
just = c("right", "top"),
vp = chrom_vp,
gp = object$gp
)
object$gp$fontface <- "bold"
chromLab <- textGrob(
label = chromLabel,
x = unit(0.5, "npc"), y = yLabel,
vp = chrom_vp,
gp = object$gp, just = c("center", "top")
)
assign("genomeLabel_grobs",
setChildren(get("genomeLabel_grobs", envir = pgEnv),
children = gList(
line, chromLab, startLab,
endLab, tickGrobs
)
),
envir = pgEnv
)
} else {
yLabel <- unit(height - margin, "native")
line <- segmentsGrob(
x0 = unit(0, "npc"), x1 = unit(1, "npc"),
y0 = height, y1 = height,
vp = chrom_vp,
gp = object$gp, default.units = "native"
)
object$gp$col <- object$gp$fontcolor
startLab <- textGrob(
label = paste(startLabel, scale, sep = " "),
x = unit(0, "npc"), y = yLabel,
vp = chrom_vp,
just = c("left", "top"),
gp = object$gp
)
endLab <- textGrob(
label = paste(endLabel, scale, sep = " "),
x = unit(1, "npc"), y = yLabel,
vp = chrom_vp,
just = c("right", "top"),
gp = object$gp
)
object$gp$fontface <- "bold"
chromLab <- textGrob(
label = chromLabel, x = unit(0.5, "npc"),
y = yLabel,
vp = chrom_vp,
gp = object$gp,
just = c("center", "top")
)
assign("genomeLabel_grobs",
setChildren(get("genomeLabel_grobs", envir = pgEnv),
children = gList(
line, chromLab,
startLab, endLab
)
),
envir = pgEnv
)
}
} else {
assign("genomeLabel_grobs", gTree(vp = vp), envir = pgEnv)
if (!is.null(ticks)) {
tgH <- convertHeight(object$tgH,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
tick_height <- convertHeight(object$tick_height,
unitTo = get("page_units",
envir = pgEnv),
valueOnly = TRUE
)
x_coords <- ticks
if (yaxis == TRUE) {
y0_coord <- 0
y1_coords <- rep(tick_height, length(ticks))
yLabel <- unit(tick_height + margin, "native")
tickGrobs <- segmentsGrob(
x0 = x_coords,
y0 = rep(y0_coord, length(ticks)),
x1 = x_coords, y1 = y1_coords,
gp = object$gp, default.units = "native"
)
line <- segmentsGrob(
x0 = unit(0, "npc"), x1 = unit(1, "npc"),
y0 = y0_coord, y1 = y0_coord,
gp = object$gp, default.units = "native"
)
object$gp$col <- object$gp$fontcolor
startLab <- textGrob(
label = paste(startLabel, scale),
x = unit(0, "npc"), y = yLabel,
just = c("left", "bottom"),
gp = object$gp
)
endLab <- textGrob(
label = paste(endLabel, scale),
x = unit(1, "npc"), y = yLabel,
just = c("right", "bottom"),
gp = object$gp
)
object$gp$fontface <- "bold"
chromLab <- textGrob(
label = chromLabel,
x = unit(0.5, "npc"), y = yLabel,
gp = object$gp, just = c("center", "bottom")
)
} else {
y0_coord <- height
y1_coords <- rep(height - tick_height, length(ticks))
yLabel <- unit(height - (tick_height + margin), "native")
tickGrobs <- segmentsGrob(
x0 = x_coords,
y0 = rep(y0_coord, length(ticks)),
x1 = x_coords, y1 = y1_coords,
gp = object$gp, default.units = "native"
)
line <- segmentsGrob(
x0 = unit(0, "npc"), x1 = unit(1, "npc"),
y0 = y0_coord, y1 = y0_coord,
gp = object$gp, default.units = "native"
)
object$gp$col <- object$gp$fontcolor
startLab <- textGrob(
label = paste(startLabel, scale),
x = unit(0, "npc"),
y = unit(tgH + 0.25 * tgH, "native"),
just = c("left", "top"),
gp = object$gp
)
endLab <- textGrob(
label = paste(endLabel, scale),
x = unit(1, "npc"),
y = unit(tgH + 0.25 * tgH, "native"),
just = c("right", "top"),
gp = object$gp
)
object$gp$fontface <- "bold"
chromLab <- textGrob(
label = chromLabel, x = unit(0.5, "npc"),
y = unit(tgH + 0.25 * tgH, "native"),
gp = object$gp, just = c("center", "top")
)
}
assign("genomeLabel_grobs",
setChildren(get("genomeLabel_grobs", envir = pgEnv),
children = gList(
line, chromLab, startLab,
endLab, tickGrobs
)
),
envir = pgEnv
)
} else {
if (yaxis == TRUE) {
yLabel <- unit(margin, "native")
line <- segmentsGrob(
x0 = unit(0, "npc"), x1 = unit(1, "npc"),
y0 = unit(0, "npc"), y1 = unit(0, "npc"),
gp = object$gp
)
object$gp$col <- object$gp$fontcolor
startLab <- textGrob(
label = paste(startLabel, scale, sep = " "),
x = unit(0, "npc"), y = yLabel,
just = c("left", "bottom"),
gp = object$gp
)
endLab <- textGrob(
label = paste(endLabel, scale, sep = " "),
x = unit(1, "npc"), y = yLabel,
just = c("right", "bottom"),
gp = object$gp
)
object$gp$fontface <- "bold"
chromLab <- textGrob(
label = chromLabel, x = unit(0.5, "npc"),
y = yLabel,
gp = object$gp,
just = c("center", "bottom")
)
} else {
yLabel <- unit(height - margin, "native")
line <- segmentsGrob(
x0 = unit(0, "npc"), x1 = unit(1, "npc"),
y0 = height, y1 = height,
gp = object$gp, default.units = "native"
)
object$gp$col <- object$gp$fontcolor
startLab <- textGrob(
label = paste(startLabel, scale, sep = " "),
x = unit(0, "npc"), y = yLabel,
just = c("left", "top"),
gp = object$gp
)
endLab <- textGrob(
label = paste(endLabel, scale, sep = " "),
x = unit(1, "npc"), y = yLabel,
just = c("right", "top"),
gp = object$gp
)
object$gp$fontface <- "bold"
chromLab <- textGrob(
label = chromLabel, x = unit(0.5, "npc"),
y = yLabel,
gp = object$gp,
just = c("center", "top")
)
}
assign("genomeLabel_grobs",
setChildren(get("genomeLabel_grobs", envir = pgEnv),
children = gList(
line, chromLab,
startLab, endLab
)
),
envir = pgEnv
)
}
}
}
## Define a function that makes sequence grobs (boxes or letters)
seq_grobs <- function(object, seqHeight, seqType, assembly, chromLabel, vp,
boxWidth, gparParams) {
bsgenome <- eval(parse(text = paste0(as.name(object$assembly$BSgenome),
"::",
as.name(object$assembly$BSgenome))))
## Get sequence in that region
sequence <- strsplit(as.character(BSgenome::getSeq(
bsgenome,
GenomicRanges::GRanges(
seqnames = chromLabel,
ranges = IRanges::IRanges(
start = object$chromstart,
end = object$chromend
)
)
)),
split = ""
)
## Make dataframe of sequence letter, position, and color
dfSequence <- data.frame(
"nucleotide" = unlist(sequence),
"pos" = seq(object$chromstart, object$chromend),
"col" = "grey"
)
## Make colors A = green, T = red, G = orange, C = blue
invisible(tryCatch(dfSequence[which(
dfSequence$nucleotide == "A"
), ]$col <- "#7CD95B",
error = function(e) {}
))
invisible(tryCatch(dfSequence[which(
dfSequence$nucleotide == "T"
), ]$col <- "#F1686C",
error = function(e) {}
))
invisible(tryCatch(dfSequence[which(
dfSequence$nucleotide == "G"
), ]$col <- "#FFDD12",
error = function(e) {}
))
invisible(tryCatch(dfSequence[which(
dfSequence$nucleotide == "C"
), ]$col <- "#5566FF",
error = function(e) {}
))
seq_vp <- vp[[2]]
## Make grobs based on seqType
if (seqType == "letters") {
seqGrobs <- textGrob(
label = dfSequence$nucleotide, x = dfSequence$pos,
y = unit(0.5, "npc"), just = "center",
vp = seq_vp,
default.units = "native",
gp = gpar(
col = dfSequence$col,
fontsize = gparParams$gp$fontsize - 2
)
)
} else if (seqType == "boxes") {
seqGrobs <- rectGrob(
x = dfSequence$pos, y = unit(1, "npc"),
width = boxWidth,
height = unit(
seqHeight - 0.05 * seqHeight,
get("page_units", envir = pgEnv)
),
just = c("center", "top"),
vp = seq_vp,
default.units = "native",
gp = gpar(col = NA, fill = dfSequence$col)
)
}
assign("genomeLabel_grobs",
addGrob(
gTree = get("genomeLabel_grobs", envir = pgEnv),
child = seqGrobs
),
envir = pgEnv
)
}
# =========================================================================
# COMMAS
# =========================================================================
## Determine scale of labels
if (genomeLabelInternal$scale == "bp") {
fact <- 1
}
if (genomeLabelInternal$scale == "Mb") {
fact <- 1000000
}
if (genomeLabelInternal$scale == "Kb") {
fact <- 1000
}
commaLabels <- comma_labels(
object = genomeLabel,
commas = genomeLabelInternal$commas,
fact = fact, ...
)
chromstartlabel <- commaLabels[[1]]
chromendlabel <- commaLabels[[2]]
# =========================================================================
# NUCLEOTIDE SEQUENCE INFORMATION
# =========================================================================
seq_height <- heightDetails(textGrob(
label = "A",
x = 0.5, y = 0.5,
default.units = "npc",
gp = gpar(fontsize = genomeLabelInternal$gp$fontsize - 2)
))
seq_height <- convertHeight(seq_height + 0.05 * seq_height,
unitTo = get("page_units", envir = pgEnv)
)
seqType <- NULL
if (genomeLabelInternal$sequence == TRUE) {
if (genomeLabelInternal$axis == "x") {
labelWidth <- convertWidth(genomeLabelInternal$length,
unitTo = "inches",
valueOnly = TRUE
)
bpWidth <- convertWidth(widthDetails(textGrob(
label = "A",
x = 0.5, y = 0.5,
default.units = "npc",
gp = gpar(fontsize = genomeLabelInternal$gp$fontsize - 2)
)),
unitTo = "inches",
valueOnly = TRUE
)
seqRange <- genomeLabel$chromend - genomeLabel$chromstart
seqWidth <- bpWidth * seqRange
if (seqWidth <= labelWidth) {
seqType <- "letters"
} else if (seqWidth / labelWidth <= 9) {
seqType <- "boxes"
}
}
}
## Check for BSgenome packages and reset seqType if necessary
if (!is.null(seqType)) {
if (!is.null(genomeLabel$assembly$BSgenome)) {
if (!requireNamespace(genomeLabel$assembly$BSgenome,
quietly = TRUE)){
bsChecks <- FALSE
warning("`", genomeLabel$assembly$BSgenome,
"` not available. ",
"Sequence information will not be displayed.",
call. = FALSE)
} else {
bsChecks <- TRUE
}
if (bsChecks == FALSE) {
seqType <- NULL
}
} else {
warning("No `BSgenome` package found for the input assembly. ",
"Sequence information cannot be displayed.", call. = FALSE)
seqType <- NULL
}
}
if (!is.null(seqType)) {
seq_height <- convertHeight(seq_height,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
genomeLabelInternal$depth <- unit(
genomeLabelInternal$depth + seq_height,
get("page_units", envir = pgEnv)
)
} else {
genomeLabelInternal$depth <- unit(
genomeLabelInternal$depth,
get("page_units", envir = pgEnv)
)
}
# =========================================================================
# VIEWPORTS
# =========================================================================
## Name viewport
currentViewports <- current_viewports()
vp_name <- paste0(
"genomeLabel",
base::length(grep(
pattern = "genomeLabel",
x = currentViewports
)) + 1
)
## Make viewport
vp <- chrom_viewport(
object = genomeLabel,
length = genomeLabelInternal$length,
depth = genomeLabelInternal$depth,
seqType = seqType,
seqHeight = seq_height,
vp_name = vp_name, just = genomeLabel$just,
axis = genomeLabelInternal$axis
)
# =========================================================================
# GROBS AND GTREE
# =========================================================================
chrom_grobs(
ticks = genomeLabelInternal$at,
seqType = seqType,
scale = genomeLabelInternal$scale,
chromLabel = genomeLabel$chrom,
startLabel = chromstartlabel, endLabel = chromendlabel,
object = genomeLabelInternal, vp = vp,
yaxis = (genomeLabelInternal$axis == "y")
)
## Sequence grobs if applicable
if (!is.null(seqType)) {
seq_grobs(
object = genomeLabel, seqHeight = seq_height,
seqType = seqType, assembly = genomeLabel$assembly,
chromLabel = genomeLabel$chrom, vp = vp,
boxWidth = genomeLabelInternal$boxWidth,
gparParams = genomeLabelInternal
)
}
return(vp_name)
}
# Plots a genome label for a multi-chromosomal Manhattan plot
# @param genomeLabel genomeLabel object from plotGenomeLabel
# @param genomeLabelInternal genomeLabelInternal object
# from plotGenomeLabel
plotManhattanGenomeLabel <- function(genomeLabel, genomeLabelInternal){
# =========================================================================
# FUNCTIONS
# =========================================================================
## Define a function that makes the label viewport
manhattan_viewport <- function(object, length, depth,
vp_name, just, axis, space){
## Convert to page units
convertedPageCoords <- convert_page(object = structure(list(
width = length,
height = unit(
depth,
get("page_units", envir = pgEnv)
),
x = object$x,
y = object$y
),
class = "genomeLabelInternal"
))
## Add "length" and "depth" into converted dimensions
convertedPageCoords$length <- convertedPageCoords$width
convertedPageCoords$depth <- convertedPageCoords$height
## Compile new dimensions into a new dummy viewport,
## where the default is along the x-axis
convertedViewport <- viewport(
width = convertedPageCoords$length,
height = convertedPageCoords$depth,
x = convertedPageCoords$x,
y = convertedPageCoords$y, just = just
)
## Get assembly data
if (is(object$assembly$TxDb, "TxDb")) {
txdbChecks <- TRUE
} else {
if (!requireNamespace(object$assembly$TxDb, quietly = TRUE)){
txdbChecks <- FALSE
warning("`", object$assembly$TxDb, "` not available. Please ",
"install to label genome.", call. = FALSE)
} else {
txdbChecks <- TRUE
}
}
if (txdbChecks == TRUE) {
if (is(object$assembly$TxDb, "TxDb")) {
tx_db <- object$assembly$TxDb
} else {
tx_db <- eval(parse(text = paste0(as.name(object$assembly$TxDb),
"::",
as.name(object$assembly$TxDb))))
}
assembly_data <- as.data.frame(setDT(as.data.frame(
GenomeInfoDb::seqlengths(tx_db)
),
keep.rownames = TRUE
))
colnames(assembly_data) <- c("chrom", "length")
assembly_data <- assembly_data[which(assembly_data[, "chrom"] %in%
object$chrom), ]
## get the offsets based on spacer for the assembly
offsetAssembly <- spaceChroms(
assemblyData = assembly_data,
space = space
)
cumsums <- cumsum(as.numeric(assembly_data[, "length"]))
spacer <- cumsums[length(cumsum(
as.numeric(assembly_data[, "length"])
))] * space
xscale <- c(0, max(offsetAssembly[, "end"]) + spacer)
} else {
xscale <- c(0, 1)
}
if (axis == "y") {
## Update converted viewport for y-axis
convertedViewport <- viewport(
width = convertedPageCoords$depth,
height = convertedPageCoords$length,
x = convertedPageCoords$x,
y = convertedPageCoords$y, just = just
)
## Get x and y coordinates of bottom right to rotate
## x-axis viewport
bottomRightViewport <-
vp_bottomRight(viewport = convertedViewport)
## Make x-axis equivalent viewport and rotate into
## dimensions of given y-axis viewport
vp <- viewport(
width = convertedPageCoords$length,
height = convertedPageCoords$depth,
x = bottomRightViewport[[1]] - convertedPageCoords$depth,
y = bottomRightViewport[[2]],
just = c("left", "top"),
name = vp_name,
xscale = c(object$chromstart, object$chromend),
yscale = c(0, depth),
angle = 90
)
} else {
vp <- viewport(
width = convertedPageCoords$width,
height = convertedPageCoords$height,
x = convertedPageCoords$x,
y = convertedPageCoords$y,
just = just,
name = vp_name,
xscale = xscale,
yscale = c(0, depth)
)
}
return(vp)
}
## Define a function that makes line and text grobs for whole assembly
## labels in Manhattan plots
genome_grobs <- function(object, vp, gp, space) {
## Initialize gTree
assign("genomeLabel_grobs", gTree(vp = vp), envir = pgEnv)
## Get assembly data
if (is(object$assembly$TxDb, "TxDb")) {
txdbChecks <- TRUE
} else {
if (!requireNamespace(object$assembly$TxDb, quietly = TRUE)){
txdbChecks <- FALSE
} else {
txdbChecks <- TRUE
}
}
if (txdbChecks == TRUE) {
if (is(object$assembly$TxDb, "TxDb")) {
tx_db <- object$assembly$TxDb
} else {
tx_db <- eval(parse(text =
paste0(as.name(object$assembly$TxDb),
"::",
as.name(object$assembly$TxDb))))
}
assembly_data <- as.data.frame(setDT(as.data.frame(
GenomeInfoDb::seqlengths(tx_db)
),
keep.rownames = TRUE
))
colnames(assembly_data) <- c("chrom", "length")
assembly_data <- assembly_data[which(assembly_data[, "chrom"] %in%
object$chrom), ]
## Get the offsets based on spacer for the assembly
offsetAssembly <- spaceChroms(
assemblyData = assembly_data,
space = space
)
## Get the centers of each chrom
chromCenters <- (offsetAssembly[, "start"] +
offsetAssembly[, "end"]) / 2
margin <- convertHeight(object$margin,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
line <- segmentsGrob(
x0 = unit(0, "npc"), x1 = unit(1, "npc"),
y0 = unit(1, "npc"), y1 = unit(1, "npc"), gp = gp
)
gp$col <- gp$fontcolor
labels <- textGrob(
label = gsub("chr", "", offsetAssembly[, 1]),
x = chromCenters,
y = unit(1, "npc") - unit(margin, "native"),
just = c("center", "top"),
gp = gp,
default.units = "native"
)
assign("genomeLabel_grobs",
setChildren(get("genomeLabel_grobs", envir = pgEnv),
children = gList(line, labels)
),
envir = pgEnv
)
}
}
# =========================================================================
# VIEWPORTS
# =========================================================================
## Name viewport
currentViewports <- current_viewports()
vp_name <- paste0(
"genomeLabel",
base::length(grep(
pattern = "genomeLabel",
x = currentViewports
)) + 1
)
## Make viewport
vp <- manhattan_viewport(
object = genomeLabel,
length = genomeLabelInternal$length,
depth = genomeLabelInternal$depth,
vp_name = vp_name, just = genomeLabel$just,
axis = genomeLabelInternal$axis,
space = genomeLabelInternal$space
)
# =========================================================================
# GROBS AND GTREE
# =========================================================================
genome_grobs(
object = genomeLabelInternal, vp = vp,
gp = genomeLabelInternal$gp,
space = genomeLabelInternal$space
)
return(vp_name)
}
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.