R/plotPairs.R
In PhanstielLab/BentoBox: Coordinate-Based Genomic Visualization Package for R
Defines functions
plotPairs
Documented in
plotPairs
#' Plot paired-end genomic range elements
#'
#' @usage plotPairs(
#' data,
#' chrom,
#' chromstart = NULL,
#' chromend = NULL,
#' assembly = "hg38",
#' fill = "#1f4297",
#' linecolor = NA,
#' bg = NA,
#' boxHeight = unit(2, "mm"),
#' spaceWidth = 0.02,
#' spaceHeight = 0.3,
#' limitLabel = TRUE,
#' baseline = FALSE,
#' baseline.color = "grey",
#' baseline.lwd = 1,
#' x = NULL,
#' y = NULL,
#' width = NULL,
#' height = NULL,
#' just = c("left", "top"),
#' default.units = "inches",
#' draw = TRUE,
#' params = NULL,
#' ...
#' )
#'
#' @param data A string specifying the BEDPE file path, a dataframe
#' in BEDPE format specifying data to be plotted, or a
#' \link[InteractionSet]{GInteractions} object.
#' @param chrom Chromosome of region to be plotted, as a string.
#' @param chromstart Integer start position on chromosome to be plotted.
#' @param chromend Integer end position on chromosome to be plotted.
#' @param assembly Default genome assembly as a string or a
#' \link[plotgardener]{assembly} object.
#' Default value is \code{assembly = "hg38"}.
#' @param fill A single character value, a vector, or
#' a \link[plotgardener]{colorby} object specifying fill colors of
#' paired range elements. Default value is \code{fill = "#1f4297"}.
#' @param linecolor A single character value, a vector, or a
#' \link[plotgardener]{colorby} object specifying the color of the lines
#' outlining paired range elements. Default value is \code{linecolor = NA}.
#' Special options include:
#' \itemize{
#' \item{\code{NA}: }{No line color.}
#' \item{\code{"fill"}: }{Same color as \code{fill}.}
#' }
#' @param bg Character value indicating background color.
#' Default value is \code{bg = NA}.
#' @param boxHeight A numeric or unit object specifying height of boxes
#' at either end of paired range elements.
#' Default value is \code{boxHeight = unit(2, "mm")}.
#' @param spaceWidth A numeric specifying the width of spacing between
#' paired range elements, as a fraction of the plot's genomic range.
#' Default value is \code{spaceWidth = 0.02}.
#' @param spaceHeight A numeric specifying the height of space between
#' boxes of paired range elements on different rows.
#' Default value is \code{spaceHeight = 0.3}.
#' @param limitLabel A logical value indicating whether to draw a "+"
#' when not all elements can be plotted in the plotting space. Default
#' value is \code{limitLabel = TRUE}.
#' @param baseline Logical value indicating whether to include a baseline
#' along the x-axis. Default value is \code{baseline = FALSE}.
#' @param baseline.color Baseline color.
#' Default value is \code{baseline.color = "grey"}.
#' @param baseline.lwd Baseline line width.
#' Default value is \code{baseline.lwd = 1}.
#' @param x A numeric or unit object specifying paired range plot x-location.
#' @param y A numeric, unit object, or character containing a "b"
#' combined with a numeric value specifying paired range plot y-location.
#' The character value will
#' place the paired range plot y relative to the bottom of the most recently
#' plotted plot according to the units of the plotgardener page.
#' @param width A numeric or unit object specifying paired range plot width.
#' @param height A numeric or unit object specifying paired range plot height.
#' @param just Justification of paired range plot relative
#' to its (x, y) location.
#' If there are two values, the first value specifies horizontal
#' justification and the second value specifies vertical justification.
#' Possible string values are: \code{"left"}, \code{"right"},
#' \code{"centre"}, \code{"center"}, \code{"bottom"}, and \code{"top"}.
#' Default value is \code{just = c("left", "top")}.
#' @param default.units A string indicating the default units to use
#' if \code{x}, \code{y}, \code{width}, or \code{height} are only given
#' as numerics. Default value is \code{default.units = "inches"}.
#' @param draw A logical value indicating whether graphics
#' output should be produced.
#' @param params An optional \link[plotgardener]{pgParams} object
#' containing relevant function parameters.
#' @param ... Additional grid graphical parameters. See \link[grid]{gpar}.
#'
#' @return Returns a \code{pairs} object containing relevant
#' genomic region, placement, and \link[grid]{grob} information.
#'
#' @examples
#' ## Load paired ranges data in BEDPE format
#' library(plotgardenerData)
#' data("IMR90_DNAloops_pairs")
#'
#' ## Set the coordinates
#' params <- pgParams(
#' chrom = "chr21",
#' chromstart = 27900000, chromend = 30700000,
#' assembly = "hg19",
#' width = 7
#' )
#'
#' ## Create a page
#' pageCreate(width = 7.5, height = 2.1, default.units = "inches")
#'
#' ## Add a length column
#' IMR90_DNAloops_pairs$length <-
#' (IMR90_DNAloops_pairs$start2 - IMR90_DNAloops_pairs$start1) / 1000
#'
#' ## Plot the data
#' bedpePlot <- plotPairs(
#' data = IMR90_DNAloops_pairs, params = params,
#' fill = colorby("length", palette =
#' colorRampPalette(c("dodgerblue2", "firebrick2"))),
#' lwd = 2, spaceHeight = .7,
#' x = 0.25, y = 0.25, height = 1.5,
#' just = c("left", "top"), default.units = "inches"
#' )
#'
#' ## Annotate genome label
#' annoGenomeLabel(plot = bedpePlot, x = 0.25, y = 1.78, scale = "Mb")
#'
#' ## Add heatmap legend
#' annoHeatmapLegend(
#' plot = bedpePlot, fontcolor = "black",
#' x = 7.0, y = 0.25,
#' width = 0.10, height = 1, fontsize = 10
#' )
#'
#' ## Add heatmap legend label
#' plotText(
#' label = "Kb", rot = 90, x = 6.9, y = 0.75,
#' just = c("center", "center"), fontsize = 10
#' )
#'
#' ## Hide page guides
#' pageGuideHide()
#' @details
#' #' A paired ranges plot can be placed on a plotgardener coordinate page
#' by providing plot placement parameters:
#' \preformatted{
#' plotPairs(data, chrom,
#' chromstart = NULL, chromend = NULL,
#' x, y, width, height, just = c("left", "top"),
#' default.units = "inches")
#' }
#' This function can also be used to quickly plot an unannotated paired
#' ranges plot by ignoring plot placement parameters:
#' \preformatted{
#' plotPairs(data, chrom,
#' chromstart = NULL, chromend = NULL)
#' }
#'
#' @export
plotPairs <- function(data, chrom, chromstart = NULL, chromend = NULL,
assembly = "hg38", fill = "#1f4297",
linecolor = NA, bg = NA, boxHeight = unit(2, "mm"),
spaceWidth = 0.02, spaceHeight = 0.3,
limitLabel = TRUE,
baseline = FALSE, baseline.color = "grey",
baseline.lwd = 1,
x = NULL, y = NULL, width = NULL, height = NULL,
just = c("left", "top"), default.units = "inches",
draw = TRUE, params = NULL, ...) {
# =========================================================================
# FUNCTIONS
# =========================================================================
## Define a function that catches errors
errorcheck_plotPairs <- function(bedpeData, bedpePlot, fill) {
## Genomic region
regionErrors(chromstart = bedpePlot$chromstart,
chromend = bedpePlot$chromend)
## Fill colorby checks
checkColorby(fill = fill,
colorby = TRUE,
data = bedpeData)
}
# =========================================================================
# PARSE PARAMETERS
# =========================================================================
bedpeInternal <- parseParams(
params = params,
defaultArgs = formals(eval(match.call()[[1]])),
declaredArgs = lapply(match.call()[-1], eval.parent, n = 2),
class = "bedpeInternal"
)
## Parse gp
bedpeInternal$gp <- setGP(
gpList = gpar(),
params = bedpeInternal, ...
)
## Justification
bedpeInternal$just <- justConversion(just = bedpeInternal$just)
# =========================================================================
# CHECK ARGUMENT ERRORS
# =========================================================================
if (is.null(bedpeInternal$data)) stop("argument \"data\" is missing, ",
"with no default.", call. = FALSE)
if (is.null(bedpeInternal$chrom)) stop("argument \"chrom\" is missing, ",
"with no default.", call. = FALSE)
# =========================================================================
# INITIALIZE OBJECT
# =========================================================================
bedpe <- structure(list(
bedpeData = NULL, chrom = bedpeInternal$chrom,
chromstart = bedpeInternal$chromstart,
chromend = bedpeInternal$chromend,
assembly = bedpeInternal$assembly,
color_palette = NULL,
zrange = NULL,
x = bedpeInternal$x, y = bedpeInternal$y,
width = bedpeInternal$width,
height = bedpeInternal$height,
just = bedpeInternal$just, grobs = NULL
),
class = "pairs"
)
attr(x = bedpe, which = "plotted") <- bedpeInternal$draw
# =========================================================================
# CHECK PLACEMENT
# =========================================================================
check_placement(object = bedpe)
# =========================================================================
# PARSE ASSEMBLY
# =========================================================================
bedpe$assembly <- parseAssembly(assembly = bedpe$assembly)
# =========================================================================
# PARSE UNITS
# =========================================================================
bedpe <- defaultUnits(
object = bedpe,
default.units = bedpeInternal$default.units
)
bedpeInternal$boxHeight <- misc_defaultUnits(
value = bedpeInternal$boxHeight,
name = "boxHeight",
default.units = bedpeInternal$default.units
)
# =========================================================================
# READ IN FILE OR DATAFRAME
# =========================================================================
bedpeData <- read_pairedData(data = bedpeInternal$data,
assembly = bedpe$assembly)
# =========================================================================
# CATCH ERRORS
# =========================================================================
errorcheck_plotPairs(
bedpeData = bedpeData, bedpePlot = bedpe,
fill = bedpeInternal$fill
)
## chrom format and data chrom format
chromDataAgreement(data = bedpeData, chrom = bedpe$chrom,
type = "pairs")
# =========================================================================
# ORGANIZE DATA
# =========================================================================
## Get appropriate starts/stops
start1 <- apply(bedpeData[, c("start1", "end1")], 1, min)
stop1 <- apply(bedpeData[, c("start1", "end1")], 1, max)
start2 <- apply(bedpeData[, c("start2", "end2")], 1, min)
stop2 <- apply(bedpeData[, c("start2", "end2")], 1, max)
bedpeData$start1 <- start1
bedpeData$end1 <- stop1
bedpeData$start2 <- start2
bedpeData$end2 <- stop2
# =========================================================================
# GENOMIC SCALE
# =========================================================================
scaleChecks <- genomicScale(object = bedpe,
objectInternal = bedpeInternal,
plotType = "paired data plot")
bedpe <- scaleChecks[[1]]
bedpeInternal <- scaleChecks[[2]]
# =========================================================================
# COLORS
# =========================================================================
pairColors <- parseColors(data = bedpeData,
fill = bedpeInternal$fill,
object = bedpe,
subset = "pairs")
if (length(pairColors[[1]]) > 0){
bedpeData$color <- pairColors[[1]]
} else {
bedpeData$color <- rep("#1f4297", nrow(bedpeData))
}
bedpe <- pairColors[[2]]
bedpeData$linecolor <- lineColors(linecolor = bedpeInternal$linecolor,
fillcolors = bedpeData$color,
data = bedpeData,
object = bedpe,
subset = "pairs")
# =========================================================================
# SUBSET DATA FOR CHROMOSOME AND ANY OVERLAPPING REGIONS
# =========================================================================
if (!is.null(bedpe$chromstart) & !is.null(bedpe$chromend)) {
bedpeData <- bedpeData[which(bedpeData[, "chrom1"] == bedpe$chrom &
bedpeData[, "chrom2"] == bedpe$chrom),]
overlappingRanges <- as.data.frame(subsetByOverlaps(ranges =
IRanges(start = bedpe$chromstart,
end = bedpe$chromend),
x = IRanges(start = bedpeData[,"start1"],
end = bedpeData[,"end2"])))
bedpeData <- bedpeData[which(bedpeData[,"start1"] %in%
overlappingRanges$start &
bedpeData[,"end2"] %in%
overlappingRanges$end),]
} else {
bedpeData <- data.frame(matrix(nrow = 0, ncol = 6))
}
# =========================================================================
# GET BOX WIDTHS AND TOTAL DISTANCES
# =========================================================================
bedpeData$width1 <- bedpeData[, "end1"] - bedpeData[, "start1"]
bedpeData$width2 <- bedpeData[, "end2"] - bedpeData[, "start2"]
bedpeData$pos1 <- rowMeans(bedpeData[, c("start1", "end1")])
bedpeData$pos2 <- rowMeans(bedpeData[, c("start2", "end2")])
bedpeData$distance <- abs(bedpeData$pos2 - bedpeData$pos1)
# =========================================================================
# SORT BY DISTANCE FOR PRETTIER PLOTTING
# =========================================================================
bedpeData <- bedpeData[order(bedpeData$distance, decreasing = TRUE), ]
# =========================================================================
# VIEWPORTS
# =========================================================================
## If placing information is provided but plot == TRUE,
## set up it's own viewport separate
## Not translating into page_coordinates
if (is.null(bedpe$x) | is.null(bedpe$y)) {
vp <- viewport(
height = unit(0.5, "snpc"), width = unit(1, "snpc"),
x = unit(0.5, "npc"), y = unit(0.5, "npc"),
clip = "on",
xscale = bedpeInternal$xscale,
yscale = c(0, 1),
just = "center",
name = "pairs1"
)
if (bedpeInternal$draw == TRUE) {
grid.newpage()
}
} else {
## Get viewport name
currentViewports <- current_viewports()
vp_name <- paste0(
"pairs",
length(grep(
pattern = "pairs",
x = currentViewports
)) + 1
)
addViewport(vp_name)
## Convert coordinates into same units as page
page_coords <- convert_page(object = bedpe)
## Make viewport
vp <- viewport(
height = page_coords$height, width = page_coords$width,
x = page_coords$x, y = page_coords$y,
clip = "on",
xscale = bedpeInternal$xscale,
yscale = c(0, convertHeight(page_coords$height,
unitTo = get("page_units",
envir = pgEnv
),
valueOnly = TRUE
)),
just = bedpeInternal$just,
name = vp_name
)
}
# =========================================================================
# INITIALIZE GTREE FOR GROBS WITH BACKGROUND
# =========================================================================
backgroundGrob <- rectGrob(gp = gpar(
fill = bedpeInternal$bg,
col = NA
), name = "background")
assign("bedpe_grobs", gTree(
vp = vp,
children = gList(backgroundGrob)
),
envir = pgEnv
)
# =========================================================================
# DETERMINE ROWS FOR EACH ELEMENT
# =========================================================================
if (nrow(bedpeData) > 0) {
if (is.null(bedpe$x) & is.null(bedpe$y)) {
pushViewport(vp)
boxHeight <- convertHeight(bedpeInternal$boxHeight,
unitTo = "npc", valueOnly = TRUE
)
spaceHeight <- boxHeight * (bedpeInternal$spaceHeight)
upViewport()
} else {
boxHeight <- convertHeight(bedpeInternal$boxHeight,
unitTo = get("page_units",
envir = pgEnv),
valueOnly = TRUE
)
spaceHeight <- boxHeight * (bedpeInternal$spaceHeight)
}
## Determine how many pair elements are going to fit
maxRows <- floor((as.numeric(vp$height) + spaceHeight) /
(boxHeight + spaceHeight))
wiggle <- abs(bedpe$chromend - bedpe$chromstart) *
bedpeInternal$spaceWidth
## Assign rows
rowData <- assignRows(data = bedpeData[,c("start1","end2","start2")],
maxRows = maxRows,
wiggle = wiggle,
rowCol = 3,
limitLabel = bedpeInternal$limitLabel,
gTree = "bedpe_grobs",
extraData = bedpeData[,c("color", "linecolor",
"width1",
"width2", "pos1",
"pos2", "distance")],
colNames = c("color", "linecolor",
"width1", "width2",
"pos1", "pos2", "distance"))
## Calculate y-coordinates
rowData$y <- rowData$row * (boxHeight + spaceHeight)
# =====================================================================
# MAKE GROBS
# =====================================================================
if (bedpeInternal$baseline == TRUE) {
baselineGrob <- segmentsGrob(
x0 = unit(0, "npc"), y0 = 0,
x1 = unit(1, "npc"), y1 = 0,
default.units = "native",
gp = gpar(
col = bedpeInternal$baseline.color,
lwd = bedpeInternal$baseline.lwd
)
)
assign("bedpe_grobs",
addGrob(
gTree = get("bedpe_grobs", envir = pgEnv),
child = baselineGrob
),
envir = pgEnv
)
}
bedpeInternal$gp$fill <- rowData$color
bedpeInternal$gp$col <- rowData$linecolor
bedpeRect1 <- rectGrob(
x = rowData[,"start1"],
y = rowData$y,
width = rowData$width1,
height = boxHeight,
just = c("left", "bottom"),
default.units = "native",
gp = bedpeInternal$gp
)
bedpeRect2 <- rectGrob(
x = rowData[,"start2"],
y = rowData$y,
width = rowData$width2,
height = boxHeight,
just = c("left", "bottom"),
default.units = "native",
gp = bedpeInternal$gp
)
bedpeInternal$gp$col <- rowData$color
bedpeInternal$gp$lineend <- "butt"
bedpeLine <- segmentsGrob(
x0 = rowData$pos1,
y0 = rowData$y + 0.5 * boxHeight,
x1 = rowData$pos2,
y1 = rowData$y + 0.5 * boxHeight,
default.units = "native",
gp = bedpeInternal$gp
)
assign("bedpe_grobs",
addGrob(
gTree = get("bedpe_grobs", envir = pgEnv),
child = bedpeLine
),
envir = pgEnv
)
assign("bedpe_grobs",
addGrob(
gTree = get("bedpe_grobs", envir = pgEnv),
child = bedpeRect1
),
envir = pgEnv
)
assign("bedpe_grobs",
addGrob(
gTree = get("bedpe_grobs", envir = pgEnv),
child = bedpeRect2
),
envir = pgEnv
)
} else {
if (bedpeInternal$txdbChecks == TRUE) {
warning("Data contains no values.", call. = FALSE)
}
}
# =========================================================================
# IF PLOT == TRUE, DRAW GROBS
# =========================================================================
if (bedpeInternal$draw == TRUE) {
grid.draw(get("bedpe_grobs", envir = pgEnv))
}
# =========================================================================
# ADD GROBS TO OBJECT
# =========================================================================
bedpe$grobs <- get("bedpe_grobs", envir = pgEnv)
# =========================================================================
# RETURN OBJECT
# =========================================================================
message("pairs[", vp$name, "]")
invisible(bedpe)
}
PhanstielLab/BentoBox documentation built on June 30, 2024, 12:50 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions plotPairs
Documented in plotPairs
#' Plot paired-end genomic range elements
#'
#' @usage plotPairs(
#' data,
#' chrom,
#' chromstart = NULL,
#' chromend = NULL,
#' assembly = "hg38",
#' fill = "#1f4297",
#' linecolor = NA,
#' bg = NA,
#' boxHeight = unit(2, "mm"),
#' spaceWidth = 0.02,
#' spaceHeight = 0.3,
#' limitLabel = TRUE,
#' baseline = FALSE,
#' baseline.color = "grey",
#' baseline.lwd = 1,
#' x = NULL,
#' y = NULL,
#' width = NULL,
#' height = NULL,
#' just = c("left", "top"),
#' default.units = "inches",
#' draw = TRUE,
#' params = NULL,
#' ...
#' )
#'
#' @param data A string specifying the BEDPE file path, a dataframe
#' in BEDPE format specifying data to be plotted, or a
#' \link[InteractionSet]{GInteractions} object.
#' @param chrom Chromosome of region to be plotted, as a string.
#' @param chromstart Integer start position on chromosome to be plotted.
#' @param chromend Integer end position on chromosome to be plotted.
#' @param assembly Default genome assembly as a string or a
#' \link[plotgardener]{assembly} object.
#' Default value is \code{assembly = "hg38"}.
#' @param fill A single character value, a vector, or
#' a \link[plotgardener]{colorby} object specifying fill colors of
#' paired range elements. Default value is \code{fill = "#1f4297"}.
#' @param linecolor A single character value, a vector, or a
#' \link[plotgardener]{colorby} object specifying the color of the lines
#' outlining paired range elements. Default value is \code{linecolor = NA}.
#' Special options include:
#' \itemize{
#' \item{\code{NA}: }{No line color.}
#' \item{\code{"fill"}: }{Same color as \code{fill}.}
#' }
#' @param bg Character value indicating background color.
#' Default value is \code{bg = NA}.
#' @param boxHeight A numeric or unit object specifying height of boxes
#' at either end of paired range elements.
#' Default value is \code{boxHeight = unit(2, "mm")}.
#' @param spaceWidth A numeric specifying the width of spacing between
#' paired range elements, as a fraction of the plot's genomic range.
#' Default value is \code{spaceWidth = 0.02}.
#' @param spaceHeight A numeric specifying the height of space between
#' boxes of paired range elements on different rows.
#' Default value is \code{spaceHeight = 0.3}.
#' @param limitLabel A logical value indicating whether to draw a "+"
#' when not all elements can be plotted in the plotting space. Default
#' value is \code{limitLabel = TRUE}.
#' @param baseline Logical value indicating whether to include a baseline
#' along the x-axis. Default value is \code{baseline = FALSE}.
#' @param baseline.color Baseline color.
#' Default value is \code{baseline.color = "grey"}.
#' @param baseline.lwd Baseline line width.
#' Default value is \code{baseline.lwd = 1}.
#' @param x A numeric or unit object specifying paired range plot x-location.
#' @param y A numeric, unit object, or character containing a "b"
#' combined with a numeric value specifying paired range plot y-location.
#' The character value will
#' place the paired range plot y relative to the bottom of the most recently
#' plotted plot according to the units of the plotgardener page.
#' @param width A numeric or unit object specifying paired range plot width.
#' @param height A numeric or unit object specifying paired range plot height.
#' @param just Justification of paired range plot relative
#' to its (x, y) location.
#' If there are two values, the first value specifies horizontal
#' justification and the second value specifies vertical justification.
#' Possible string values are: \code{"left"}, \code{"right"},
#' \code{"centre"}, \code{"center"}, \code{"bottom"}, and \code{"top"}.
#' Default value is \code{just = c("left", "top")}.
#' @param default.units A string indicating the default units to use
#' if \code{x}, \code{y}, \code{width}, or \code{height} are only given
#' as numerics. Default value is \code{default.units = "inches"}.
#' @param draw A logical value indicating whether graphics
#' output should be produced.
#' @param params An optional \link[plotgardener]{pgParams} object
#' containing relevant function parameters.
#' @param ... Additional grid graphical parameters. See \link[grid]{gpar}.
#'
#' @return Returns a \code{pairs} object containing relevant
#' genomic region, placement, and \link[grid]{grob} information.
#'
#' @examples
#' ## Load paired ranges data in BEDPE format
#' library(plotgardenerData)
#' data("IMR90_DNAloops_pairs")
#'
#' ## Set the coordinates
#' params <- pgParams(
#' chrom = "chr21",
#' chromstart = 27900000, chromend = 30700000,
#' assembly = "hg19",
#' width = 7
#' )
#'
#' ## Create a page
#' pageCreate(width = 7.5, height = 2.1, default.units = "inches")
#'
#' ## Add a length column
#' IMR90_DNAloops_pairs$length <-
#' (IMR90_DNAloops_pairs$start2 - IMR90_DNAloops_pairs$start1) / 1000
#'
#' ## Plot the data
#' bedpePlot <- plotPairs(
#' data = IMR90_DNAloops_pairs, params = params,
#' fill = colorby("length", palette =
#' colorRampPalette(c("dodgerblue2", "firebrick2"))),
#' lwd = 2, spaceHeight = .7,
#' x = 0.25, y = 0.25, height = 1.5,
#' just = c("left", "top"), default.units = "inches"
#' )
#'
#' ## Annotate genome label
#' annoGenomeLabel(plot = bedpePlot, x = 0.25, y = 1.78, scale = "Mb")
#'
#' ## Add heatmap legend
#' annoHeatmapLegend(
#' plot = bedpePlot, fontcolor = "black",
#' x = 7.0, y = 0.25,
#' width = 0.10, height = 1, fontsize = 10
#' )
#'
#' ## Add heatmap legend label
#' plotText(
#' label = "Kb", rot = 90, x = 6.9, y = 0.75,
#' just = c("center", "center"), fontsize = 10
#' )
#'
#' ## Hide page guides
#' pageGuideHide()
#' @details
#' #' A paired ranges plot can be placed on a plotgardener coordinate page
#' by providing plot placement parameters:
#' \preformatted{
#' plotPairs(data, chrom,
#' chromstart = NULL, chromend = NULL,
#' x, y, width, height, just = c("left", "top"),
#' default.units = "inches")
#' }
#' This function can also be used to quickly plot an unannotated paired
#' ranges plot by ignoring plot placement parameters:
#' \preformatted{
#' plotPairs(data, chrom,
#' chromstart = NULL, chromend = NULL)
#' }
#'
#' @export
plotPairs <- function(data, chrom, chromstart = NULL, chromend = NULL,
assembly = "hg38", fill = "#1f4297",
linecolor = NA, bg = NA, boxHeight = unit(2, "mm"),
spaceWidth = 0.02, spaceHeight = 0.3,
limitLabel = TRUE,
baseline = FALSE, baseline.color = "grey",
baseline.lwd = 1,
x = NULL, y = NULL, width = NULL, height = NULL,
just = c("left", "top"), default.units = "inches",
draw = TRUE, params = NULL, ...) {
# =========================================================================
# FUNCTIONS
# =========================================================================
## Define a function that catches errors
errorcheck_plotPairs <- function(bedpeData, bedpePlot, fill) {
## Genomic region
regionErrors(chromstart = bedpePlot$chromstart,
chromend = bedpePlot$chromend)
## Fill colorby checks
checkColorby(fill = fill,
colorby = TRUE,
data = bedpeData)
}
# =========================================================================
# PARSE PARAMETERS
# =========================================================================
bedpeInternal <- parseParams(
params = params,
defaultArgs = formals(eval(match.call()[[1]])),
declaredArgs = lapply(match.call()[-1], eval.parent, n = 2),
class = "bedpeInternal"
)
## Parse gp
bedpeInternal$gp <- setGP(
gpList = gpar(),
params = bedpeInternal, ...
)
## Justification
bedpeInternal$just <- justConversion(just = bedpeInternal$just)
# =========================================================================
# CHECK ARGUMENT ERRORS
# =========================================================================
if (is.null(bedpeInternal$data)) stop("argument \"data\" is missing, ",
"with no default.", call. = FALSE)
if (is.null(bedpeInternal$chrom)) stop("argument \"chrom\" is missing, ",
"with no default.", call. = FALSE)
# =========================================================================
# INITIALIZE OBJECT
# =========================================================================
bedpe <- structure(list(
bedpeData = NULL, chrom = bedpeInternal$chrom,
chromstart = bedpeInternal$chromstart,
chromend = bedpeInternal$chromend,
assembly = bedpeInternal$assembly,
color_palette = NULL,
zrange = NULL,
x = bedpeInternal$x, y = bedpeInternal$y,
width = bedpeInternal$width,
height = bedpeInternal$height,
just = bedpeInternal$just, grobs = NULL
),
class = "pairs"
)
attr(x = bedpe, which = "plotted") <- bedpeInternal$draw
# =========================================================================
# CHECK PLACEMENT
# =========================================================================
check_placement(object = bedpe)
# =========================================================================
# PARSE ASSEMBLY
# =========================================================================
bedpe$assembly <- parseAssembly(assembly = bedpe$assembly)
# =========================================================================
# PARSE UNITS
# =========================================================================
bedpe <- defaultUnits(
object = bedpe,
default.units = bedpeInternal$default.units
)
bedpeInternal$boxHeight <- misc_defaultUnits(
value = bedpeInternal$boxHeight,
name = "boxHeight",
default.units = bedpeInternal$default.units
)
# =========================================================================
# READ IN FILE OR DATAFRAME
# =========================================================================
bedpeData <- read_pairedData(data = bedpeInternal$data,
assembly = bedpe$assembly)
# =========================================================================
# CATCH ERRORS
# =========================================================================
errorcheck_plotPairs(
bedpeData = bedpeData, bedpePlot = bedpe,
fill = bedpeInternal$fill
)
## chrom format and data chrom format
chromDataAgreement(data = bedpeData, chrom = bedpe$chrom,
type = "pairs")
# =========================================================================
# ORGANIZE DATA
# =========================================================================
## Get appropriate starts/stops
start1 <- apply(bedpeData[, c("start1", "end1")], 1, min)
stop1 <- apply(bedpeData[, c("start1", "end1")], 1, max)
start2 <- apply(bedpeData[, c("start2", "end2")], 1, min)
stop2 <- apply(bedpeData[, c("start2", "end2")], 1, max)
bedpeData$start1 <- start1
bedpeData$end1 <- stop1
bedpeData$start2 <- start2
bedpeData$end2 <- stop2
# =========================================================================
# GENOMIC SCALE
# =========================================================================
scaleChecks <- genomicScale(object = bedpe,
objectInternal = bedpeInternal,
plotType = "paired data plot")
bedpe <- scaleChecks[[1]]
bedpeInternal <- scaleChecks[[2]]
# =========================================================================
# COLORS
# =========================================================================
pairColors <- parseColors(data = bedpeData,
fill = bedpeInternal$fill,
object = bedpe,
subset = "pairs")
if (length(pairColors[[1]]) > 0){
bedpeData$color <- pairColors[[1]]
} else {
bedpeData$color <- rep("#1f4297", nrow(bedpeData))
}
bedpe <- pairColors[[2]]
bedpeData$linecolor <- lineColors(linecolor = bedpeInternal$linecolor,
fillcolors = bedpeData$color,
data = bedpeData,
object = bedpe,
subset = "pairs")
# =========================================================================
# SUBSET DATA FOR CHROMOSOME AND ANY OVERLAPPING REGIONS
# =========================================================================
if (!is.null(bedpe$chromstart) & !is.null(bedpe$chromend)) {
bedpeData <- bedpeData[which(bedpeData[, "chrom1"] == bedpe$chrom &
bedpeData[, "chrom2"] == bedpe$chrom),]
overlappingRanges <- as.data.frame(subsetByOverlaps(ranges =
IRanges(start = bedpe$chromstart,
end = bedpe$chromend),
x = IRanges(start = bedpeData[,"start1"],
end = bedpeData[,"end2"])))
bedpeData <- bedpeData[which(bedpeData[,"start1"] %in%
overlappingRanges$start &
bedpeData[,"end2"] %in%
overlappingRanges$end),]
} else {
bedpeData <- data.frame(matrix(nrow = 0, ncol = 6))
}
# =========================================================================
# GET BOX WIDTHS AND TOTAL DISTANCES
# =========================================================================
bedpeData$width1 <- bedpeData[, "end1"] - bedpeData[, "start1"]
bedpeData$width2 <- bedpeData[, "end2"] - bedpeData[, "start2"]
bedpeData$pos1 <- rowMeans(bedpeData[, c("start1", "end1")])
bedpeData$pos2 <- rowMeans(bedpeData[, c("start2", "end2")])
bedpeData$distance <- abs(bedpeData$pos2 - bedpeData$pos1)
# =========================================================================
# SORT BY DISTANCE FOR PRETTIER PLOTTING
# =========================================================================
bedpeData <- bedpeData[order(bedpeData$distance, decreasing = TRUE), ]
# =========================================================================
# VIEWPORTS
# =========================================================================
## If placing information is provided but plot == TRUE,
## set up it's own viewport separate
## Not translating into page_coordinates
if (is.null(bedpe$x) | is.null(bedpe$y)) {
vp <- viewport(
height = unit(0.5, "snpc"), width = unit(1, "snpc"),
x = unit(0.5, "npc"), y = unit(0.5, "npc"),
clip = "on",
xscale = bedpeInternal$xscale,
yscale = c(0, 1),
just = "center",
name = "pairs1"
)
if (bedpeInternal$draw == TRUE) {
grid.newpage()
}
} else {
## Get viewport name
currentViewports <- current_viewports()
vp_name <- paste0(
"pairs",
length(grep(
pattern = "pairs",
x = currentViewports
)) + 1
)
addViewport(vp_name)
## Convert coordinates into same units as page
page_coords <- convert_page(object = bedpe)
## Make viewport
vp <- viewport(
height = page_coords$height, width = page_coords$width,
x = page_coords$x, y = page_coords$y,
clip = "on",
xscale = bedpeInternal$xscale,
yscale = c(0, convertHeight(page_coords$height,
unitTo = get("page_units",
envir = pgEnv
),
valueOnly = TRUE
)),
just = bedpeInternal$just,
name = vp_name
)
}
# =========================================================================
# INITIALIZE GTREE FOR GROBS WITH BACKGROUND
# =========================================================================
backgroundGrob <- rectGrob(gp = gpar(
fill = bedpeInternal$bg,
col = NA
), name = "background")
assign("bedpe_grobs", gTree(
vp = vp,
children = gList(backgroundGrob)
),
envir = pgEnv
)
# =========================================================================
# DETERMINE ROWS FOR EACH ELEMENT
# =========================================================================
if (nrow(bedpeData) > 0) {
if (is.null(bedpe$x) & is.null(bedpe$y)) {
pushViewport(vp)
boxHeight <- convertHeight(bedpeInternal$boxHeight,
unitTo = "npc", valueOnly = TRUE
)
spaceHeight <- boxHeight * (bedpeInternal$spaceHeight)
upViewport()
} else {
boxHeight <- convertHeight(bedpeInternal$boxHeight,
unitTo = get("page_units",
envir = pgEnv),
valueOnly = TRUE
)
spaceHeight <- boxHeight * (bedpeInternal$spaceHeight)
}
## Determine how many pair elements are going to fit
maxRows <- floor((as.numeric(vp$height) + spaceHeight) /
(boxHeight + spaceHeight))
wiggle <- abs(bedpe$chromend - bedpe$chromstart) *
bedpeInternal$spaceWidth
## Assign rows
rowData <- assignRows(data = bedpeData[,c("start1","end2","start2")],
maxRows = maxRows,
wiggle = wiggle,
rowCol = 3,
limitLabel = bedpeInternal$limitLabel,
gTree = "bedpe_grobs",
extraData = bedpeData[,c("color", "linecolor",
"width1",
"width2", "pos1",
"pos2", "distance")],
colNames = c("color", "linecolor",
"width1", "width2",
"pos1", "pos2", "distance"))
## Calculate y-coordinates
rowData$y <- rowData$row * (boxHeight + spaceHeight)
# =====================================================================
# MAKE GROBS
# =====================================================================
if (bedpeInternal$baseline == TRUE) {
baselineGrob <- segmentsGrob(
x0 = unit(0, "npc"), y0 = 0,
x1 = unit(1, "npc"), y1 = 0,
default.units = "native",
gp = gpar(
col = bedpeInternal$baseline.color,
lwd = bedpeInternal$baseline.lwd
)
)
assign("bedpe_grobs",
addGrob(
gTree = get("bedpe_grobs", envir = pgEnv),
child = baselineGrob
),
envir = pgEnv
)
}
bedpeInternal$gp$fill <- rowData$color
bedpeInternal$gp$col <- rowData$linecolor
bedpeRect1 <- rectGrob(
x = rowData[,"start1"],
y = rowData$y,
width = rowData$width1,
height = boxHeight,
just = c("left", "bottom"),
default.units = "native",
gp = bedpeInternal$gp
)
bedpeRect2 <- rectGrob(
x = rowData[,"start2"],
y = rowData$y,
width = rowData$width2,
height = boxHeight,
just = c("left", "bottom"),
default.units = "native",
gp = bedpeInternal$gp
)
bedpeInternal$gp$col <- rowData$color
bedpeInternal$gp$lineend <- "butt"
bedpeLine <- segmentsGrob(
x0 = rowData$pos1,
y0 = rowData$y + 0.5 * boxHeight,
x1 = rowData$pos2,
y1 = rowData$y + 0.5 * boxHeight,
default.units = "native",
gp = bedpeInternal$gp
)
assign("bedpe_grobs",
addGrob(
gTree = get("bedpe_grobs", envir = pgEnv),
child = bedpeLine
),
envir = pgEnv
)
assign("bedpe_grobs",
addGrob(
gTree = get("bedpe_grobs", envir = pgEnv),
child = bedpeRect1
),
envir = pgEnv
)
assign("bedpe_grobs",
addGrob(
gTree = get("bedpe_grobs", envir = pgEnv),
child = bedpeRect2
),
envir = pgEnv
)
} else {
if (bedpeInternal$txdbChecks == TRUE) {
warning("Data contains no values.", call. = FALSE)
}
}
# =========================================================================
# IF PLOT == TRUE, DRAW GROBS
# =========================================================================
if (bedpeInternal$draw == TRUE) {
grid.draw(get("bedpe_grobs", envir = pgEnv))
}
# =========================================================================
# ADD GROBS TO OBJECT
# =========================================================================
bedpe$grobs <- get("bedpe_grobs", envir = pgEnv)
# =========================================================================
# RETURN OBJECT
# =========================================================================
message("pairs[", vp$name, "]")
invisible(bedpe)
}
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.