R/plotIdeogram.R
In PhanstielLab/plotgardener: Coordinate-Based Genomic Visualization Package for R
Defines functions
plotIdeogram
Documented in
plotIdeogram
#' Plot a chromosome ideogram with or without cytobands
#'
#' @usage plotIdeogram(
#' chrom,
#' assembly = "hg38",
#' data = NULL,
#' orientation = "h",
#' flip = FALSE,
#' showBands = TRUE,
#' fill = NULL,
#' x = NULL,
#' y = NULL,
#' width = NULL,
#' height = NULL,
#' just = c("left", "top"),
#' default.units = "inches",
#' draw = TRUE,
#' params = NULL
#' )
#'
#' @param chrom Chromosome to be plotted, as a string.
#' @param assembly Default genome assembly as a string or a
#' \link[plotgardener]{assembly} object.
#' Default value is \code{assembly = "hg38"}.
#' @param data Custom cytoband data, as a dataframe with the following
#' columns: "seqnames", "start", "end", "width", "strand",
#' "name", "gieStain".
#' @param orientation Character value indicating the orientation
#' of the ideogram. Default value is \code{orientation = "h"}.
#' Options are:
#' \itemize{
#' \item{\code{"v"}: }{Vertical ideogram orientation.}
#' \item{\code{"h"}: }{Horizontal ideogram orientation.}
#' }
#' @param flip Logical value indicating whether to reverse the start and end
#' positions of the ideogram. If \code{flip = FALSE} (default), the ideogram
#' starts at the top/left and ends at the bottom/right. If \code{flip = TRUE},
#' the start and end positions are reversed, meaning the ideogram starts at the
#' bottom/right and ends at the top/left.
#' @param showBands Logical value indicating whether to draw
#' colored cytobands within ideogram.
#' Default value is \code{showBands = TRUE}.
#' @param fill (optional) A vector specifying alternate colors for cytoband
#' stains. To change specific gieStain values (i.e. gneg, gpos, etc.) to
#' specific colors, this vector can be named. This vector must have the same
#' number of colors as there are gieStain values for each genome assembly.
#' @param x A numeric or unit object specifying ideogram x-location.
#' @param y A numeric, unit object, or character containing a "b"
#' combined with a numeric value specifying ideogram y-location.
#' The character value will
#' place the ideogram 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 ideogram width.
#' @param height A numeric or unit object specifying ideogram height.
#' @param just Justification of ideogram 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{ideogram} object containing relevant
#' genomic region, placement, and \link[grid]{grob} information.
#'
#' @examples
#' ## Load Giemsa stain band information and genomic
#' ## annotation data for hg19 genome assembly
#' library(TxDb.Hsapiens.UCSC.hg19.knownGene)
#' library(AnnotationHub)
#'
#' ## Create page
#' pageCreate(width = 4.5, height = 1, default.units = "inches")
#'
#' ## Plot and place ideogram
#' ideogramPlot <- plotIdeogram(
#' chrom = "chr2", assembly = "hg19",
#' x = 0.25, y = 0.25, width = 4, height = 0.3,
#' just = c("left", "top"),
#' default.units = "inches"
#' )
#'
#' ## Plot text
#' plotText(
#' label = "Chromosome 2", fontcolor = "dark grey",
#' x = 4.25, y = 0.65, just = "right"
#' )
#'
#' ## Hide page guides
#' pageGuideHide()
#' @details
#' An ideogram can be placed on a plotgardener coordinate page by
#' providing plot placement parameters:
#' \preformatted{
#' plotIdeogram(chrom,
#' x, y, width, height, just = c("left", "top"),
#' default.units = "inches")
#' }
#' This function can also be used to quickly plot an unannotated ideogram
#' by ignoring plot placement parameters:
#' \preformatted{
#' plotIdeogram(chrom)
#' }
#' If no data is provided, Giemsa stain band data will first try to
#' fetch UCSC with AnnotationHub. The results are cached for faster access,
#' but these cached items can be deleted. If no internet connection is
#' available and AnnotationHub has not previously cached the data, custom
#' Giemsa stain band data can be loaded with the `data` parameter.
#'
#' @seealso \link[AnnotationHub]{AnnotationHub}
#'
#' @export
plotIdeogram <- function(chrom, assembly = "hg38", data = NULL,
orientation = "h", flip = FALSE,
showBands = TRUE, fill = NULL,
x = NULL, y = NULL,
width = NULL, height = NULL,
just = c("left", "top"), default.units = "inches",
draw = TRUE, params = NULL) {
# =========================================================================
# FUNCTIONS
# =========================================================================
## Define a function that checks errors for plotIdeogram
errorcheck_plotIdeogram <- function(orientation) {
if (!orientation %in% c("v", "h")) {
stop("Invalid /'orientation/' parameter. Options are 'v' or 'h'.",
call. = FALSE
)
}
}
## Define a function to get cytoBand data for a genome assembly
cytoAssembly <- function(assembly) {
## Get string assembly name
assemblyName <- assembly$Genome
## Check in defaults for data
if(!any(cytoband_AH_assembly$assembly %in% assemblyName)){
warning("UCSC cytoBand data not available for the given genome",
" assembly. Default data can only be found for the",
" following assemblies:",
cat(cytoband_AH_assembly$assembly, sep = ", "),
". Please provide custom data for input assembly.",
call. = FALSE)
cytoData <- NULL
} else {
# Load data from AHCytoBands
if (!requireNamespace("AnnotationHub",
quietly = TRUE)){
warning("Please install `AnnotationHub` ",
"to plot an ideogram for a default",
" genome assembly.", call. = FALSE)
cytoData <- NULL
} else {
assemblyName <- cytoband_AH_assembly[
cytoband_AH_assembly$assembly%in% assemblyName,]$assembly
# Get name of AH object for assembly
AH_id <- cytoband_AH_assembly[cytoband_AH_assembly$assembly ==
assemblyName,]$AH
# Check for internet
if (has_internet()){
# Load AHCytoBands data
cytobands <- suppressMessages(AnnotationHub::query(
AnnotationHub::AnnotationHub(), "AHCytoBands"))
# Grab data for assembly
cytoData <- as.data.frame(
suppressMessages(cytobands[[AH_id]]))
} else {
# Try with localHub=TRUE for cache
errorFunction <- function(c){
return(NULL)
}
cytobands <-
tryCatch(
suppressMessages(
AnnotationHub::query(AnnotationHub::AnnotationHub(localHub = TRUE),
"AHCytoBands")),
error = errorFunction
)
if (!is.null(cytobands)){
cytoData <- as.data.frame(
suppressMessages(cytobands[[AH_id]]))
} else {
cytoData <- NULL
}
}
}
}
return(cytoData)
}
## Define a function to check that a chromosome name is in a TxDb
checkChroms <- function(chrom, txdb) {
if (is(txdb, "TxDb")) {
tx_db <- txdb
} else {
tx_db <- eval(parse(text = paste0(as.name(txdb), "::",
as.name(txdb))))
}
txdbChroms <- GenomeInfoDb::seqlevels(tx_db)
if (chrom %in% txdbChroms) {
return(TRUE)
} else {
warning("'", chrom, "'",
"not found in", txdb$packageName, ".",
call. = FALSE
)
return(FALSE)
}
}
## Define a function that draws bands that fall within left curved regions
curvedBands_left <- function(df, xCurve, yCurve, ymax) {
start <- utils::type.convert(df["start"], as.is = TRUE)
end <- utils::type.convert(df["end"], as.is = TRUE)
col <- df["color"]
if (end > max(xCurve)) {
xpoints <- c(xCurve[which(xCurve >= start)], end, end)
ypoints <- c(yCurve[which(xCurve >= start)], 0, ymax)
} else {
xpoints <- xCurve[which(xCurve >= start & xCurve <= end)]
ypoints <- yCurve[which(xCurve >= start & xCurve <= end)]
}
if (length(xpoints) > 0 & length(ypoints) > 0) {
curvedGrob <- polygonGrob(
x = xpoints, y = ypoints,
default.units = "native",
gp = gpar(fill = col, col = NA)
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = curvedGrob
),
envir = pgEnv
)
}
}
## Define a function that draws bands that fall within right curved regions
curvedBands_right <- function(df, xCurve, yCurve, ymax) {
start <- utils::type.convert(df["start"], as.is = TRUE)
end <- utils::type.convert(df["end"], as.is = TRUE)
col <- df["color"]
if (start < min(xCurve)) {
xpoints <- c(xCurve[which(xCurve <= end)], start, start)
ypoints <- c(yCurve[which(xCurve <= end)], ymax, 0)
} else {
xpoints <- xCurve[which(xCurve >= start & xCurve <= end)]
ypoints <- yCurve[which(xCurve >= start & xCurve <= end)]
}
if (length(xpoints) > 0 & length(ypoints) > 0) {
curvedGrob <- polygonGrob(
x = xpoints, y = ypoints,
default.units = "native",
gp = gpar(fill = col, col = NA)
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = curvedGrob
),
envir = pgEnv
)
}
}
# =========================================================================
# PARSE PARAMETERS
# =========================================================================
ideoInternal <- parseParams(
params = params,
defaultArgs = formals(eval(match.call()[[1]])),
declaredArgs = lapply(match.call()[-1], eval.parent, n = 2),
class = "ideoInternal"
)
## Justification
ideoInternal$just <- justConversion(just = ideoInternal$just)
# =========================================================================
# INITIALIZE OBJECT
# =========================================================================
ideogramPlot <- structure(list(
chrom = ideoInternal$chrom,
chromstart = 1, chromend = NULL,
assembly = ideoInternal$assembly,
colors = NULL,
x = ideoInternal$x, y = ideoInternal$y,
width = ideoInternal$width,
height = ideoInternal$height,
just = ideoInternal$just, grobs = NULL
),
class = "ideogram"
)
attr(x = ideogramPlot, which = "plotted") <- ideoInternal$draw
# =========================================================================
# CATCH ERRORS
# =========================================================================
if (is.null(ideogramPlot$chrom)) {
stop("argument \"chrom\" is missing, with no default.", call. = FALSE)
}
check_placement(object = ideogramPlot)
errorcheck_plotIdeogram(orientation = ideoInternal$orientation)
# =========================================================================
# PARSE ASSEMBLY
# =========================================================================
ideogramPlot$assembly <-
parseAssembly(assembly = ideogramPlot$assembly)
# =========================================================================
# PARSE UNITS
# =========================================================================
ideogramPlot <- defaultUnits(
object = ideogramPlot,
default.units = ideoInternal$default.units
)
# =========================================================================
# GET APPROPRIATE BUILD DATA
# =========================================================================
if (is.null(ideoInternal$data)){
data <- cytoAssembly(assembly = ideogramPlot$assembly)
} else {
data <- as.data.frame(ideoInternal$data)
colnames(data) <- c("seqnames", "start", "end", "width", "strand",
"name", "gieStain")
}
## TxDb data
if (is(ideogramPlot$assembly$TxDb, "TxDb")){
genome <- ideogramPlot$assembly$TxDb
} else {
if (!requireNamespace(ideogramPlot$assembly$TxDb, quietly = TRUE)){
warning("`", ideogramPlot$assembly$TxDb, "` not available. ",
"Please install to plot ideogram.", call. = FALSE)
genome <- NULL
} else {
genome <- eval(parse(text =
paste0(as.name(ideogramPlot$assembly$TxDb), "::",
as.name(ideogramPlot$assembly$TxDb))))
}
}
chromLength <- 1
if (!is.null(data) & !is.null(genome)) {
chromCheck <- checkChroms(chrom = ideoInternal$chrom,
txdb = ideogramPlot$assembly$TxDb)
if (chromCheck == TRUE) {
# =================================================================
# ADD COLORS
# =================================================================
if (!is.null(ideoInternal$fill)){
## Check that length of fill vector is the same length as the
## of gieStain values in the data
if (length(unique(data$gieStain)) != length(ideoInternal$fill)){
warning("`fill` color vector is not the same length as",
" number of gieStain values. Using default colors.")
colors <- cytobandColors
} else {
if (is.null(names(ideoInternal$fill))){
## No names, assign in order of levels
data$gieStain <- as.factor(data$gieStain)
colors <- data.frame("gieStain" = levels(data$gieStain),
"color" = ideoInternal$fill)
} else {
## Assign colors based on names
colors$gieStain <-
data.frame("gieStain" = names(ideoInternal$fill),
"color" = ideoInternal$fill)
}
}
} else {
colors <- cytobandColors
}
data <- dplyr::left_join(data, colors, by = "gieStain")
## Add stains/colors to object
objectCols <- unique(data[,c("gieStain", "color")])
row.names(objectCols) <- NULL
ideogramPlot$colors <- objectCols
# =================================================================
# SUBSET FOR CHROMOSOME
# =================================================================
data <- data[which(data[, 1] == ideogramPlot$chrom), ]
data$seqnames <- as.character(data$seqnames)
data$strand <- as.character(data$strand)
data$name <- as.character(data$name)
data$gieStain <- as.character(data$gieStain)
chromLength <- GenomeInfoDb::seqlengths(genome)[[
ideogramPlot$chrom]]
ideogramPlot$chromend <- chromLength
}
}
# =========================================================================
# VIEWPORTS
# =========================================================================
## If placing information is provided but plot == TRUE,
## set up it's own viewport separate from bb_makepage
## Not translating into page_coordinates
if (is.null(ideogramPlot$x) | is.null(ideogramPlot$y)) {
height <- 0.075
width <- 1
scaleRatio <- width / height
yscale <- chromLength / scaleRatio
angleAdjust <- ifelse(ideoInternal$flip, yes = 180, no = 0)
if (ideoInternal$orientation == "h") {
vp <- viewport(
height = unit(height, "snpc"),
width = unit(width, "snpc"),
x = unit(0.5, "npc"), y = unit(0.5, "npc"),
xscale = c(0, chromLength),
yscale = c(0, yscale),
angle = 0 + angleAdjust,
just = "center",
name = "ideogram1"
)
} else {
height <- 1
width <- 0.075
vp <- viewport(
height = unit(width, "snpc"),
width = unit(height, "snpc"),
x = unit(0.5, "npc"), y = unit(0.5, "npc"),
xscale = c(0, chromLength),
yscale = c(0, yscale),
angle = -90 + angleAdjust,
just = "center",
name = "ideogram1"
)
}
if (ideoInternal$draw == TRUE) {
grid.newpage()
}
} else {
## Get viewport name
currentViewports <- current_viewports()
vp_name <- paste0("ideogram", length(grep(
pattern = "ideogram",
x = currentViewports
)) + 1)
## Convert coordinates into same units as page
page_coords <- convert_page(object = ideogramPlot)
addViewport(vp_name)
height <- convertHeight(page_coords$height,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
width <- convertWidth(page_coords$width,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
scaleRatio <- max(c(width, height)) / min(c(width, height))
yscale <- chromLength / scaleRatio
if (ideoInternal$orientation == "h") {
## Make viewport based on user inputs
vp <- viewport(
height = page_coords$height,
width = page_coords$width,
x = page_coords$x, y = page_coords$y,
xscale = c(0, chromLength),
yscale = c(0, yscale),
just = ideoInternal$just,
name = vp_name)
## Convert viewport to bottom left (bottom left of horizontal)
if(ideoInternal$flip) {
vp_br <- vp_bottomRight(viewport = vp)
vp <- viewport(
height = page_coords$height,
width = page_coords$width,
x = vp_br[[1]], y = vp_br[[2]],
xscale = c(0, chromLength),
yscale = c(0, yscale),
angle = 180,
just = c("left", "top"),
name = vp_name
) }
} else {
## Make viewport based on user inputs
vpOG <- viewport(
height = page_coords$height,
width = page_coords$width,
x = page_coords$x, y = page_coords$y,
just = ideoInternal$just
)
## Convert viewport to bottom left (bottom left of horizontal)
## if flip == TRUE
if(ideoInternal$flip) {
vp_bl <- vp_bottomLeft(viewport = vpOG)
vp <- viewport(
height = page_coords$width,
width = page_coords$height,
x = vp_bl[[1]], y = vp_bl[[2]],
xscale = c(0, chromLength),
yscale = c(0, yscale),
angle = 90,
just = c("left", "top"),
name = vp_name
)
}
## Convert viewport to top right (top right of horizontal)
## if flip == FALSE
else{
vp_tr <- vp_topRight(viewport = vpOG)
vp <- viewport(
height = page_coords$width,
width = page_coords$height,
x = vp_tr[[1]], y = vp_tr[[2]],
xscale = c(0, chromLength),
yscale = c(0, yscale),
angle = -90,
just = c("left", "top"),
name = vp_name
)
}
}
}
# =========================================================================
# INITIALIZE GTREE FOR GROBS
# =========================================================================
assign("ideogram_grobs", gTree(vp = vp), envir = pgEnv)
if (!is.null(data) & !is.null(genome)) {
if (chromCheck == TRUE) {
# =================================================================
# CHROMOSOME GROBS
# =================================================================
## Generate points along curves for the ends
r <- vp$yscale[2] * 0.5
leftAngles <- seq(pi / 2, 3 * pi / 2, pi / 500)
rightAngles <- seq(3 * pi / 2, 5 * pi / 2, pi / 500)
leftXpoints <- r + r * cos(leftAngles)
leftYpoints <- r + r * sin(leftAngles)
rightXpoints <- (chromLength - r) + r * cos(rightAngles)
rightYpoints <- r + r * sin(rightAngles)
if (nrow(data) > 1) {
## FIRST BAND ##
firstBand <- data[which(data$start == 1), ]
data <- subset(data, data$start != 1)
if (firstBand$end > max(leftXpoints)) {
firstBand_Xpoints <- c(
leftXpoints, firstBand$end,
firstBand$end
)
firstBand_Ypoints <- c(leftYpoints, 0, vp$yscale[2])
} else {
firstBand_Xpoints <- leftXpoints[which(leftXpoints <=
firstBand$end)]
firstBand_Ypoints <- leftYpoints[which(leftXpoints <=
firstBand$end)]
}
if (ideoInternal$showBands == TRUE) {
firstBand_grob <- polygonGrob(
x = firstBand_Xpoints,
y = firstBand_Ypoints,
default.units = "native",
gp = gpar(
fill = firstBand$color,
col = NA
)
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = firstBand_grob
),
envir = pgEnv
)
}
## LAST BAND ##
lastBand <- data[which(data$end == chromLength), ]
data <- subset(data, data$end != chromLength)
if (lastBand$start < min(rightXpoints)) {
lastBand_Xpoints <- c(
rightXpoints, lastBand$start,
lastBand$start
)
lastBand_Ypoints <- c(rightYpoints, vp$yscale[2], 0)
} else {
lastBand_Xpoints <- rightXpoints[which(rightXpoints >=
lastBand$start)]
lastBand_Ypoints <- rightYpoints[which(rightXpoints >=
lastBand$start)]
}
if (ideoInternal$showBands == TRUE) {
lastBand_grob <- polygonGrob(
x = lastBand_Xpoints,
y = lastBand_Ypoints,
default.units = "native",
gp = gpar(
fill = lastBand$color,
col = NA
)
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = lastBand_grob
),
envir = pgEnv
)
}
if (ideoInternal$assembly %in% c("hg18", "hg19", "hg38")) {
## CENTER BANDS ##
leftCent <- data[which(data$gieStain == "acen"), ][1, ]
leftCent_length <- leftCent$end - leftCent$start
rightCent <- data[which(data$gieStain == "acen"), ][2, ]
rightCent_length <- rightCent$end - rightCent$start
centerX <- leftCent$end
data <- subset(data, data$gieStain != "acen")
## Generate points along curves for the centers
centerleftXpoints <- (centerX - r * 0.75) +
r * cos(rightAngles)
centerleftYpoints <- r + r * sin(rightAngles)
centerleftYpoints <- centerleftYpoints[which(
centerleftXpoints <= (rightCent$end - 0.5 *
rightCent_length)
)]
centerleftXpoints <- centerleftXpoints[which(
centerleftXpoints <= (rightCent$end - 0.5 *
rightCent_length)
)]
centerrightXpoints <- (centerX + r * 0.75) + r *
cos(leftAngles)
centerrightYpoints <- r + r * sin(leftAngles)
centerrightYpoints <- centerrightYpoints[which(
centerrightXpoints >= (leftCent$start + 0.5 *
leftCent_length)
)]
centerrightXpoints <- centerrightXpoints[which(
centerrightXpoints >= (leftCent$start + 0.5 *
leftCent_length)
)]
## CENTER LEFT BAND ##
if (leftCent$start < min(centerleftXpoints)) {
leftCent_Xpoints <- c(
centerleftXpoints, leftCent$start,
leftCent$start
)
leftCent_Ypoints <- c(
centerleftYpoints,
vp$yscale[2], 0
)
} else {
leftCent_Xpoints <- centerleftXpoints[which(
centerleftXpoints >= leftCent$start
)]
leftCent_Ypoints <- centerleftYpoints[which(
centerleftXpoints >= leftCent$start
)]
}
if (ideoInternal$showBands == TRUE) {
leftCent_grob <- polygonGrob(
x = leftCent_Xpoints,
y = leftCent_Ypoints,
default.units = "native",
gp = gpar(fill = leftCent$color, col = NA)
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = leftCent_grob
),
envir = pgEnv
)
}
## CENTER RIGHT BAND ##
if (rightCent$end > max(centerrightXpoints)) {
rightCent_Xpoints <- c(
centerrightXpoints, rightCent$end,
rightCent$end
)
rightCent_Ypoints <- c(
centerrightYpoints, 0,
vp$yscale[2]
)
} else {
rightCent_Xpoints <- centerrightXpoints[which(
centerrightXpoints <= rightCent$end
)]
rightCent_Ypoints <- centerrightYpoints[which(
centerrightXpoints <= rightCent$end
)]
}
if (ideoInternal$showBands == TRUE) {
rightCent_grob <- polygonGrob(
x = rightCent_Xpoints,
y = rightCent_Ypoints,
default.units = "native",
gp = gpar(
fill = rightCent$color,
col = NA
)
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = rightCent_grob
),
envir = pgEnv
)
}
## GET ANY BANDS THAT FALL WITHIN CENTER CURVED REGIONS ##
if (ideoInternal$showBands == TRUE) {
inleftcurvedBands <- data[which(
data$end > min(centerleftXpoints) &
data$end <= centerX
), ]
inrightcurvedBands <- data[which(
data$start < max(centerrightXpoints) &
data$start >= centerX
), ]
if (nrow(inleftcurvedBands > 0)) {
invisible(apply(inleftcurvedBands,
1,
curvedBands_right,
xCurve = centerleftXpoints,
yCurve = centerleftYpoints,
ymax = vp$yscale[2]
))
}
if (nrow(inrightcurvedBands > 0)) {
invisible(apply(inrightcurvedBands,
1,
curvedBands_left,
xCurve = centerrightXpoints,
yCurve = centerrightYpoints,
ymax = vp$yscale[2]
))
}
## REMAINING BANDS ##
data <- suppressMessages(dplyr::anti_join(
data, inleftcurvedBands
))
data <- suppressMessages(dplyr::anti_join(
data, inrightcurvedBands
))
}
}
if (ideoInternal$showBands == TRUE) {
## GET ANY BANDS THAT FALL WITHIN OUTSIDE CURVED REGIONS ##
leftcurvedBands <- data[which(data$start <
max(leftXpoints)), ]
rightcurvedBands <- data[which(data$start >=
min(rightXpoints)), ]
if (nrow(leftcurvedBands > 0)) {
invisible(apply(leftcurvedBands,
1,
curvedBands_left,
xCurve = leftXpoints,
yCurve = leftYpoints,
ymax = vp$yscale[2]
))
}
if (nrow(rightcurvedBands > 0)) {
invisible(apply(rightcurvedBands,
1,
curvedBands_right,
xCurve = rightXpoints,
yCurve = rightYpoints,
ymax = vp$yscale[2]
))
}
## REMAINING BANDS ##
data <- suppressMessages(dplyr::anti_join(
data,
leftcurvedBands
))
data <- suppressMessages(dplyr::anti_join(
data,
rightcurvedBands
))
rectBands <- rectGrob(
x = data$start, y = unit(0.5, "npc"),
width = data$width, height = unit(1, "npc"),
just = "left", default.units = "native",
gp = gpar(fill = data$color, col = NA)
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = rectBands
),
envir = pgEnv
)
}
}
# =================================================================
# OUTLINE GROBS
# =================================================================
if (ideoInternal$assembly %in% c("hg18", "hg19", "hg38")) {
topIntersectY <- sqrt(r^2 - ((r * 0.75)^2)) + r
bottomIntersectY <- -1 * sqrt(r^2 - ((r * 0.75)^2)) + r
lbottomX <- centerleftXpoints[which(
centerleftXpoints <= centerX &
centerleftYpoints <= bottomIntersectY
)]
lbottomY <- centerleftYpoints[which(
centerleftXpoints <= centerX &
centerleftYpoints <= bottomIntersectY
)]
rbottomX <- centerrightXpoints[which(
centerrightXpoints >= centerX &
centerrightYpoints <= bottomIntersectY
)]
rbottomY <- centerrightYpoints[which(
centerrightXpoints >= centerX &
centerrightYpoints <= bottomIntersectY
)]
rtopX <- centerrightXpoints[which(
centerrightXpoints >= centerX &
centerrightYpoints >= topIntersectY
)]
rtopY <- centerrightYpoints[which(
centerrightXpoints >= centerX &
centerrightYpoints >= topIntersectY
)]
ltopX <- centerleftXpoints[which(
centerleftXpoints <= centerX &
centerleftYpoints >= topIntersectY
)]
ltopY <- centerleftYpoints[which(
centerleftXpoints <= centerX &
centerleftYpoints >= topIntersectY
)]
Xoutline <- c(
leftXpoints, lbottomX, centerX, rbottomX,
rightXpoints, rtopX, centerX, ltopX
)
Youtline <- c(
leftYpoints, lbottomY, bottomIntersectY, rbottomY,
rightYpoints, rtopY, topIntersectY, ltopY
)
} else {
Xoutline <- c(leftXpoints, rightXpoints)
Youtline <- c(leftYpoints, rightYpoints)
}
outlineGrob <- polygonGrob(
x = Xoutline, y = Youtline,
default.units = "native",
gp = gpar(fill = NA, col = "#d0cfd4")
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = outlineGrob
),
envir = pgEnv
)
}
}
# =========================================================================
# IF PLOT == TRUE, DRAW GROBS
# =========================================================================
if (ideoInternal$draw == TRUE) {
grid.draw(get("ideogram_grobs", envir = pgEnv))
}
# =========================================================================
# ADD GROBS TO OBJECT
# =========================================================================
ideogramPlot$grobs <- get("ideogram_grobs", envir = pgEnv)
# =========================================================================
# RETURN OBJECT
# =========================================================================
message("ideogram[", vp$name, "]")
invisible(ideogramPlot)
}
PhanstielLab/plotgardener documentation built on May 7, 2024, 4:21 a.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 plotIdeogram
Documented in plotIdeogram
#' Plot a chromosome ideogram with or without cytobands
#'
#' @usage plotIdeogram(
#' chrom,
#' assembly = "hg38",
#' data = NULL,
#' orientation = "h",
#' flip = FALSE,
#' showBands = TRUE,
#' fill = NULL,
#' x = NULL,
#' y = NULL,
#' width = NULL,
#' height = NULL,
#' just = c("left", "top"),
#' default.units = "inches",
#' draw = TRUE,
#' params = NULL
#' )
#'
#' @param chrom Chromosome to be plotted, as a string.
#' @param assembly Default genome assembly as a string or a
#' \link[plotgardener]{assembly} object.
#' Default value is \code{assembly = "hg38"}.
#' @param data Custom cytoband data, as a dataframe with the following
#' columns: "seqnames", "start", "end", "width", "strand",
#' "name", "gieStain".
#' @param orientation Character value indicating the orientation
#' of the ideogram. Default value is \code{orientation = "h"}.
#' Options are:
#' \itemize{
#' \item{\code{"v"}: }{Vertical ideogram orientation.}
#' \item{\code{"h"}: }{Horizontal ideogram orientation.}
#' }
#' @param flip Logical value indicating whether to reverse the start and end
#' positions of the ideogram. If \code{flip = FALSE} (default), the ideogram
#' starts at the top/left and ends at the bottom/right. If \code{flip = TRUE},
#' the start and end positions are reversed, meaning the ideogram starts at the
#' bottom/right and ends at the top/left.
#' @param showBands Logical value indicating whether to draw
#' colored cytobands within ideogram.
#' Default value is \code{showBands = TRUE}.
#' @param fill (optional) A vector specifying alternate colors for cytoband
#' stains. To change specific gieStain values (i.e. gneg, gpos, etc.) to
#' specific colors, this vector can be named. This vector must have the same
#' number of colors as there are gieStain values for each genome assembly.
#' @param x A numeric or unit object specifying ideogram x-location.
#' @param y A numeric, unit object, or character containing a "b"
#' combined with a numeric value specifying ideogram y-location.
#' The character value will
#' place the ideogram 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 ideogram width.
#' @param height A numeric or unit object specifying ideogram height.
#' @param just Justification of ideogram 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{ideogram} object containing relevant
#' genomic region, placement, and \link[grid]{grob} information.
#'
#' @examples
#' ## Load Giemsa stain band information and genomic
#' ## annotation data for hg19 genome assembly
#' library(TxDb.Hsapiens.UCSC.hg19.knownGene)
#' library(AnnotationHub)
#'
#' ## Create page
#' pageCreate(width = 4.5, height = 1, default.units = "inches")
#'
#' ## Plot and place ideogram
#' ideogramPlot <- plotIdeogram(
#' chrom = "chr2", assembly = "hg19",
#' x = 0.25, y = 0.25, width = 4, height = 0.3,
#' just = c("left", "top"),
#' default.units = "inches"
#' )
#'
#' ## Plot text
#' plotText(
#' label = "Chromosome 2", fontcolor = "dark grey",
#' x = 4.25, y = 0.65, just = "right"
#' )
#'
#' ## Hide page guides
#' pageGuideHide()
#' @details
#' An ideogram can be placed on a plotgardener coordinate page by
#' providing plot placement parameters:
#' \preformatted{
#' plotIdeogram(chrom,
#' x, y, width, height, just = c("left", "top"),
#' default.units = "inches")
#' }
#' This function can also be used to quickly plot an unannotated ideogram
#' by ignoring plot placement parameters:
#' \preformatted{
#' plotIdeogram(chrom)
#' }
#' If no data is provided, Giemsa stain band data will first try to
#' fetch UCSC with AnnotationHub. The results are cached for faster access,
#' but these cached items can be deleted. If no internet connection is
#' available and AnnotationHub has not previously cached the data, custom
#' Giemsa stain band data can be loaded with the `data` parameter.
#'
#' @seealso \link[AnnotationHub]{AnnotationHub}
#'
#' @export
plotIdeogram <- function(chrom, assembly = "hg38", data = NULL,
orientation = "h", flip = FALSE,
showBands = TRUE, fill = NULL,
x = NULL, y = NULL,
width = NULL, height = NULL,
just = c("left", "top"), default.units = "inches",
draw = TRUE, params = NULL) {
# =========================================================================
# FUNCTIONS
# =========================================================================
## Define a function that checks errors for plotIdeogram
errorcheck_plotIdeogram <- function(orientation) {
if (!orientation %in% c("v", "h")) {
stop("Invalid /'orientation/' parameter. Options are 'v' or 'h'.",
call. = FALSE
)
}
}
## Define a function to get cytoBand data for a genome assembly
cytoAssembly <- function(assembly) {
## Get string assembly name
assemblyName <- assembly$Genome
## Check in defaults for data
if(!any(cytoband_AH_assembly$assembly %in% assemblyName)){
warning("UCSC cytoBand data not available for the given genome",
" assembly. Default data can only be found for the",
" following assemblies:",
cat(cytoband_AH_assembly$assembly, sep = ", "),
". Please provide custom data for input assembly.",
call. = FALSE)
cytoData <- NULL
} else {
# Load data from AHCytoBands
if (!requireNamespace("AnnotationHub",
quietly = TRUE)){
warning("Please install `AnnotationHub` ",
"to plot an ideogram for a default",
" genome assembly.", call. = FALSE)
cytoData <- NULL
} else {
assemblyName <- cytoband_AH_assembly[
cytoband_AH_assembly$assembly%in% assemblyName,]$assembly
# Get name of AH object for assembly
AH_id <- cytoband_AH_assembly[cytoband_AH_assembly$assembly ==
assemblyName,]$AH
# Check for internet
if (has_internet()){
# Load AHCytoBands data
cytobands <- suppressMessages(AnnotationHub::query(
AnnotationHub::AnnotationHub(), "AHCytoBands"))
# Grab data for assembly
cytoData <- as.data.frame(
suppressMessages(cytobands[[AH_id]]))
} else {
# Try with localHub=TRUE for cache
errorFunction <- function(c){
return(NULL)
}
cytobands <-
tryCatch(
suppressMessages(
AnnotationHub::query(AnnotationHub::AnnotationHub(localHub = TRUE),
"AHCytoBands")),
error = errorFunction
)
if (!is.null(cytobands)){
cytoData <- as.data.frame(
suppressMessages(cytobands[[AH_id]]))
} else {
cytoData <- NULL
}
}
}
}
return(cytoData)
}
## Define a function to check that a chromosome name is in a TxDb
checkChroms <- function(chrom, txdb) {
if (is(txdb, "TxDb")) {
tx_db <- txdb
} else {
tx_db <- eval(parse(text = paste0(as.name(txdb), "::",
as.name(txdb))))
}
txdbChroms <- GenomeInfoDb::seqlevels(tx_db)
if (chrom %in% txdbChroms) {
return(TRUE)
} else {
warning("'", chrom, "'",
"not found in", txdb$packageName, ".",
call. = FALSE
)
return(FALSE)
}
}
## Define a function that draws bands that fall within left curved regions
curvedBands_left <- function(df, xCurve, yCurve, ymax) {
start <- utils::type.convert(df["start"], as.is = TRUE)
end <- utils::type.convert(df["end"], as.is = TRUE)
col <- df["color"]
if (end > max(xCurve)) {
xpoints <- c(xCurve[which(xCurve >= start)], end, end)
ypoints <- c(yCurve[which(xCurve >= start)], 0, ymax)
} else {
xpoints <- xCurve[which(xCurve >= start & xCurve <= end)]
ypoints <- yCurve[which(xCurve >= start & xCurve <= end)]
}
if (length(xpoints) > 0 & length(ypoints) > 0) {
curvedGrob <- polygonGrob(
x = xpoints, y = ypoints,
default.units = "native",
gp = gpar(fill = col, col = NA)
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = curvedGrob
),
envir = pgEnv
)
}
}
## Define a function that draws bands that fall within right curved regions
curvedBands_right <- function(df, xCurve, yCurve, ymax) {
start <- utils::type.convert(df["start"], as.is = TRUE)
end <- utils::type.convert(df["end"], as.is = TRUE)
col <- df["color"]
if (start < min(xCurve)) {
xpoints <- c(xCurve[which(xCurve <= end)], start, start)
ypoints <- c(yCurve[which(xCurve <= end)], ymax, 0)
} else {
xpoints <- xCurve[which(xCurve >= start & xCurve <= end)]
ypoints <- yCurve[which(xCurve >= start & xCurve <= end)]
}
if (length(xpoints) > 0 & length(ypoints) > 0) {
curvedGrob <- polygonGrob(
x = xpoints, y = ypoints,
default.units = "native",
gp = gpar(fill = col, col = NA)
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = curvedGrob
),
envir = pgEnv
)
}
}
# =========================================================================
# PARSE PARAMETERS
# =========================================================================
ideoInternal <- parseParams(
params = params,
defaultArgs = formals(eval(match.call()[[1]])),
declaredArgs = lapply(match.call()[-1], eval.parent, n = 2),
class = "ideoInternal"
)
## Justification
ideoInternal$just <- justConversion(just = ideoInternal$just)
# =========================================================================
# INITIALIZE OBJECT
# =========================================================================
ideogramPlot <- structure(list(
chrom = ideoInternal$chrom,
chromstart = 1, chromend = NULL,
assembly = ideoInternal$assembly,
colors = NULL,
x = ideoInternal$x, y = ideoInternal$y,
width = ideoInternal$width,
height = ideoInternal$height,
just = ideoInternal$just, grobs = NULL
),
class = "ideogram"
)
attr(x = ideogramPlot, which = "plotted") <- ideoInternal$draw
# =========================================================================
# CATCH ERRORS
# =========================================================================
if (is.null(ideogramPlot$chrom)) {
stop("argument \"chrom\" is missing, with no default.", call. = FALSE)
}
check_placement(object = ideogramPlot)
errorcheck_plotIdeogram(orientation = ideoInternal$orientation)
# =========================================================================
# PARSE ASSEMBLY
# =========================================================================
ideogramPlot$assembly <-
parseAssembly(assembly = ideogramPlot$assembly)
# =========================================================================
# PARSE UNITS
# =========================================================================
ideogramPlot <- defaultUnits(
object = ideogramPlot,
default.units = ideoInternal$default.units
)
# =========================================================================
# GET APPROPRIATE BUILD DATA
# =========================================================================
if (is.null(ideoInternal$data)){
data <- cytoAssembly(assembly = ideogramPlot$assembly)
} else {
data <- as.data.frame(ideoInternal$data)
colnames(data) <- c("seqnames", "start", "end", "width", "strand",
"name", "gieStain")
}
## TxDb data
if (is(ideogramPlot$assembly$TxDb, "TxDb")){
genome <- ideogramPlot$assembly$TxDb
} else {
if (!requireNamespace(ideogramPlot$assembly$TxDb, quietly = TRUE)){
warning("`", ideogramPlot$assembly$TxDb, "` not available. ",
"Please install to plot ideogram.", call. = FALSE)
genome <- NULL
} else {
genome <- eval(parse(text =
paste0(as.name(ideogramPlot$assembly$TxDb), "::",
as.name(ideogramPlot$assembly$TxDb))))
}
}
chromLength <- 1
if (!is.null(data) & !is.null(genome)) {
chromCheck <- checkChroms(chrom = ideoInternal$chrom,
txdb = ideogramPlot$assembly$TxDb)
if (chromCheck == TRUE) {
# =================================================================
# ADD COLORS
# =================================================================
if (!is.null(ideoInternal$fill)){
## Check that length of fill vector is the same length as the
## of gieStain values in the data
if (length(unique(data$gieStain)) != length(ideoInternal$fill)){
warning("`fill` color vector is not the same length as",
" number of gieStain values. Using default colors.")
colors <- cytobandColors
} else {
if (is.null(names(ideoInternal$fill))){
## No names, assign in order of levels
data$gieStain <- as.factor(data$gieStain)
colors <- data.frame("gieStain" = levels(data$gieStain),
"color" = ideoInternal$fill)
} else {
## Assign colors based on names
colors$gieStain <-
data.frame("gieStain" = names(ideoInternal$fill),
"color" = ideoInternal$fill)
}
}
} else {
colors <- cytobandColors
}
data <- dplyr::left_join(data, colors, by = "gieStain")
## Add stains/colors to object
objectCols <- unique(data[,c("gieStain", "color")])
row.names(objectCols) <- NULL
ideogramPlot$colors <- objectCols
# =================================================================
# SUBSET FOR CHROMOSOME
# =================================================================
data <- data[which(data[, 1] == ideogramPlot$chrom), ]
data$seqnames <- as.character(data$seqnames)
data$strand <- as.character(data$strand)
data$name <- as.character(data$name)
data$gieStain <- as.character(data$gieStain)
chromLength <- GenomeInfoDb::seqlengths(genome)[[
ideogramPlot$chrom]]
ideogramPlot$chromend <- chromLength
}
}
# =========================================================================
# VIEWPORTS
# =========================================================================
## If placing information is provided but plot == TRUE,
## set up it's own viewport separate from bb_makepage
## Not translating into page_coordinates
if (is.null(ideogramPlot$x) | is.null(ideogramPlot$y)) {
height <- 0.075
width <- 1
scaleRatio <- width / height
yscale <- chromLength / scaleRatio
angleAdjust <- ifelse(ideoInternal$flip, yes = 180, no = 0)
if (ideoInternal$orientation == "h") {
vp <- viewport(
height = unit(height, "snpc"),
width = unit(width, "snpc"),
x = unit(0.5, "npc"), y = unit(0.5, "npc"),
xscale = c(0, chromLength),
yscale = c(0, yscale),
angle = 0 + angleAdjust,
just = "center",
name = "ideogram1"
)
} else {
height <- 1
width <- 0.075
vp <- viewport(
height = unit(width, "snpc"),
width = unit(height, "snpc"),
x = unit(0.5, "npc"), y = unit(0.5, "npc"),
xscale = c(0, chromLength),
yscale = c(0, yscale),
angle = -90 + angleAdjust,
just = "center",
name = "ideogram1"
)
}
if (ideoInternal$draw == TRUE) {
grid.newpage()
}
} else {
## Get viewport name
currentViewports <- current_viewports()
vp_name <- paste0("ideogram", length(grep(
pattern = "ideogram",
x = currentViewports
)) + 1)
## Convert coordinates into same units as page
page_coords <- convert_page(object = ideogramPlot)
addViewport(vp_name)
height <- convertHeight(page_coords$height,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
width <- convertWidth(page_coords$width,
unitTo = get("page_units", envir = pgEnv),
valueOnly = TRUE
)
scaleRatio <- max(c(width, height)) / min(c(width, height))
yscale <- chromLength / scaleRatio
if (ideoInternal$orientation == "h") {
## Make viewport based on user inputs
vp <- viewport(
height = page_coords$height,
width = page_coords$width,
x = page_coords$x, y = page_coords$y,
xscale = c(0, chromLength),
yscale = c(0, yscale),
just = ideoInternal$just,
name = vp_name)
## Convert viewport to bottom left (bottom left of horizontal)
if(ideoInternal$flip) {
vp_br <- vp_bottomRight(viewport = vp)
vp <- viewport(
height = page_coords$height,
width = page_coords$width,
x = vp_br[[1]], y = vp_br[[2]],
xscale = c(0, chromLength),
yscale = c(0, yscale),
angle = 180,
just = c("left", "top"),
name = vp_name
) }
} else {
## Make viewport based on user inputs
vpOG <- viewport(
height = page_coords$height,
width = page_coords$width,
x = page_coords$x, y = page_coords$y,
just = ideoInternal$just
)
## Convert viewport to bottom left (bottom left of horizontal)
## if flip == TRUE
if(ideoInternal$flip) {
vp_bl <- vp_bottomLeft(viewport = vpOG)
vp <- viewport(
height = page_coords$width,
width = page_coords$height,
x = vp_bl[[1]], y = vp_bl[[2]],
xscale = c(0, chromLength),
yscale = c(0, yscale),
angle = 90,
just = c("left", "top"),
name = vp_name
)
}
## Convert viewport to top right (top right of horizontal)
## if flip == FALSE
else{
vp_tr <- vp_topRight(viewport = vpOG)
vp <- viewport(
height = page_coords$width,
width = page_coords$height,
x = vp_tr[[1]], y = vp_tr[[2]],
xscale = c(0, chromLength),
yscale = c(0, yscale),
angle = -90,
just = c("left", "top"),
name = vp_name
)
}
}
}
# =========================================================================
# INITIALIZE GTREE FOR GROBS
# =========================================================================
assign("ideogram_grobs", gTree(vp = vp), envir = pgEnv)
if (!is.null(data) & !is.null(genome)) {
if (chromCheck == TRUE) {
# =================================================================
# CHROMOSOME GROBS
# =================================================================
## Generate points along curves for the ends
r <- vp$yscale[2] * 0.5
leftAngles <- seq(pi / 2, 3 * pi / 2, pi / 500)
rightAngles <- seq(3 * pi / 2, 5 * pi / 2, pi / 500)
leftXpoints <- r + r * cos(leftAngles)
leftYpoints <- r + r * sin(leftAngles)
rightXpoints <- (chromLength - r) + r * cos(rightAngles)
rightYpoints <- r + r * sin(rightAngles)
if (nrow(data) > 1) {
## FIRST BAND ##
firstBand <- data[which(data$start == 1), ]
data <- subset(data, data$start != 1)
if (firstBand$end > max(leftXpoints)) {
firstBand_Xpoints <- c(
leftXpoints, firstBand$end,
firstBand$end
)
firstBand_Ypoints <- c(leftYpoints, 0, vp$yscale[2])
} else {
firstBand_Xpoints <- leftXpoints[which(leftXpoints <=
firstBand$end)]
firstBand_Ypoints <- leftYpoints[which(leftXpoints <=
firstBand$end)]
}
if (ideoInternal$showBands == TRUE) {
firstBand_grob <- polygonGrob(
x = firstBand_Xpoints,
y = firstBand_Ypoints,
default.units = "native",
gp = gpar(
fill = firstBand$color,
col = NA
)
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = firstBand_grob
),
envir = pgEnv
)
}
## LAST BAND ##
lastBand <- data[which(data$end == chromLength), ]
data <- subset(data, data$end != chromLength)
if (lastBand$start < min(rightXpoints)) {
lastBand_Xpoints <- c(
rightXpoints, lastBand$start,
lastBand$start
)
lastBand_Ypoints <- c(rightYpoints, vp$yscale[2], 0)
} else {
lastBand_Xpoints <- rightXpoints[which(rightXpoints >=
lastBand$start)]
lastBand_Ypoints <- rightYpoints[which(rightXpoints >=
lastBand$start)]
}
if (ideoInternal$showBands == TRUE) {
lastBand_grob <- polygonGrob(
x = lastBand_Xpoints,
y = lastBand_Ypoints,
default.units = "native",
gp = gpar(
fill = lastBand$color,
col = NA
)
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = lastBand_grob
),
envir = pgEnv
)
}
if (ideoInternal$assembly %in% c("hg18", "hg19", "hg38")) {
## CENTER BANDS ##
leftCent <- data[which(data$gieStain == "acen"), ][1, ]
leftCent_length <- leftCent$end - leftCent$start
rightCent <- data[which(data$gieStain == "acen"), ][2, ]
rightCent_length <- rightCent$end - rightCent$start
centerX <- leftCent$end
data <- subset(data, data$gieStain != "acen")
## Generate points along curves for the centers
centerleftXpoints <- (centerX - r * 0.75) +
r * cos(rightAngles)
centerleftYpoints <- r + r * sin(rightAngles)
centerleftYpoints <- centerleftYpoints[which(
centerleftXpoints <= (rightCent$end - 0.5 *
rightCent_length)
)]
centerleftXpoints <- centerleftXpoints[which(
centerleftXpoints <= (rightCent$end - 0.5 *
rightCent_length)
)]
centerrightXpoints <- (centerX + r * 0.75) + r *
cos(leftAngles)
centerrightYpoints <- r + r * sin(leftAngles)
centerrightYpoints <- centerrightYpoints[which(
centerrightXpoints >= (leftCent$start + 0.5 *
leftCent_length)
)]
centerrightXpoints <- centerrightXpoints[which(
centerrightXpoints >= (leftCent$start + 0.5 *
leftCent_length)
)]
## CENTER LEFT BAND ##
if (leftCent$start < min(centerleftXpoints)) {
leftCent_Xpoints <- c(
centerleftXpoints, leftCent$start,
leftCent$start
)
leftCent_Ypoints <- c(
centerleftYpoints,
vp$yscale[2], 0
)
} else {
leftCent_Xpoints <- centerleftXpoints[which(
centerleftXpoints >= leftCent$start
)]
leftCent_Ypoints <- centerleftYpoints[which(
centerleftXpoints >= leftCent$start
)]
}
if (ideoInternal$showBands == TRUE) {
leftCent_grob <- polygonGrob(
x = leftCent_Xpoints,
y = leftCent_Ypoints,
default.units = "native",
gp = gpar(fill = leftCent$color, col = NA)
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = leftCent_grob
),
envir = pgEnv
)
}
## CENTER RIGHT BAND ##
if (rightCent$end > max(centerrightXpoints)) {
rightCent_Xpoints <- c(
centerrightXpoints, rightCent$end,
rightCent$end
)
rightCent_Ypoints <- c(
centerrightYpoints, 0,
vp$yscale[2]
)
} else {
rightCent_Xpoints <- centerrightXpoints[which(
centerrightXpoints <= rightCent$end
)]
rightCent_Ypoints <- centerrightYpoints[which(
centerrightXpoints <= rightCent$end
)]
}
if (ideoInternal$showBands == TRUE) {
rightCent_grob <- polygonGrob(
x = rightCent_Xpoints,
y = rightCent_Ypoints,
default.units = "native",
gp = gpar(
fill = rightCent$color,
col = NA
)
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = rightCent_grob
),
envir = pgEnv
)
}
## GET ANY BANDS THAT FALL WITHIN CENTER CURVED REGIONS ##
if (ideoInternal$showBands == TRUE) {
inleftcurvedBands <- data[which(
data$end > min(centerleftXpoints) &
data$end <= centerX
), ]
inrightcurvedBands <- data[which(
data$start < max(centerrightXpoints) &
data$start >= centerX
), ]
if (nrow(inleftcurvedBands > 0)) {
invisible(apply(inleftcurvedBands,
1,
curvedBands_right,
xCurve = centerleftXpoints,
yCurve = centerleftYpoints,
ymax = vp$yscale[2]
))
}
if (nrow(inrightcurvedBands > 0)) {
invisible(apply(inrightcurvedBands,
1,
curvedBands_left,
xCurve = centerrightXpoints,
yCurve = centerrightYpoints,
ymax = vp$yscale[2]
))
}
## REMAINING BANDS ##
data <- suppressMessages(dplyr::anti_join(
data, inleftcurvedBands
))
data <- suppressMessages(dplyr::anti_join(
data, inrightcurvedBands
))
}
}
if (ideoInternal$showBands == TRUE) {
## GET ANY BANDS THAT FALL WITHIN OUTSIDE CURVED REGIONS ##
leftcurvedBands <- data[which(data$start <
max(leftXpoints)), ]
rightcurvedBands <- data[which(data$start >=
min(rightXpoints)), ]
if (nrow(leftcurvedBands > 0)) {
invisible(apply(leftcurvedBands,
1,
curvedBands_left,
xCurve = leftXpoints,
yCurve = leftYpoints,
ymax = vp$yscale[2]
))
}
if (nrow(rightcurvedBands > 0)) {
invisible(apply(rightcurvedBands,
1,
curvedBands_right,
xCurve = rightXpoints,
yCurve = rightYpoints,
ymax = vp$yscale[2]
))
}
## REMAINING BANDS ##
data <- suppressMessages(dplyr::anti_join(
data,
leftcurvedBands
))
data <- suppressMessages(dplyr::anti_join(
data,
rightcurvedBands
))
rectBands <- rectGrob(
x = data$start, y = unit(0.5, "npc"),
width = data$width, height = unit(1, "npc"),
just = "left", default.units = "native",
gp = gpar(fill = data$color, col = NA)
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = rectBands
),
envir = pgEnv
)
}
}
# =================================================================
# OUTLINE GROBS
# =================================================================
if (ideoInternal$assembly %in% c("hg18", "hg19", "hg38")) {
topIntersectY <- sqrt(r^2 - ((r * 0.75)^2)) + r
bottomIntersectY <- -1 * sqrt(r^2 - ((r * 0.75)^2)) + r
lbottomX <- centerleftXpoints[which(
centerleftXpoints <= centerX &
centerleftYpoints <= bottomIntersectY
)]
lbottomY <- centerleftYpoints[which(
centerleftXpoints <= centerX &
centerleftYpoints <= bottomIntersectY
)]
rbottomX <- centerrightXpoints[which(
centerrightXpoints >= centerX &
centerrightYpoints <= bottomIntersectY
)]
rbottomY <- centerrightYpoints[which(
centerrightXpoints >= centerX &
centerrightYpoints <= bottomIntersectY
)]
rtopX <- centerrightXpoints[which(
centerrightXpoints >= centerX &
centerrightYpoints >= topIntersectY
)]
rtopY <- centerrightYpoints[which(
centerrightXpoints >= centerX &
centerrightYpoints >= topIntersectY
)]
ltopX <- centerleftXpoints[which(
centerleftXpoints <= centerX &
centerleftYpoints >= topIntersectY
)]
ltopY <- centerleftYpoints[which(
centerleftXpoints <= centerX &
centerleftYpoints >= topIntersectY
)]
Xoutline <- c(
leftXpoints, lbottomX, centerX, rbottomX,
rightXpoints, rtopX, centerX, ltopX
)
Youtline <- c(
leftYpoints, lbottomY, bottomIntersectY, rbottomY,
rightYpoints, rtopY, topIntersectY, ltopY
)
} else {
Xoutline <- c(leftXpoints, rightXpoints)
Youtline <- c(leftYpoints, rightYpoints)
}
outlineGrob <- polygonGrob(
x = Xoutline, y = Youtline,
default.units = "native",
gp = gpar(fill = NA, col = "#d0cfd4")
)
assign("ideogram_grobs",
addGrob(get("ideogram_grobs", envir = pgEnv),
child = outlineGrob
),
envir = pgEnv
)
}
}
# =========================================================================
# IF PLOT == TRUE, DRAW GROBS
# =========================================================================
if (ideoInternal$draw == TRUE) {
grid.draw(get("ideogram_grobs", envir = pgEnv))
}
# =========================================================================
# ADD GROBS TO OBJECT
# =========================================================================
ideogramPlot$grobs <- get("ideogram_grobs", envir = pgEnv)
# =========================================================================
# RETURN OBJECT
# =========================================================================
message("ideogram[", vp$name, "]")
invisible(ideogramPlot)
}
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.