Nothing
R/auxillary-functions-visuals.R
In AllelicImbalance: Investigates Allele Specific Expression
Defines functions
barplotLatticeCounts
barplotLatticeFraction
annotationBarplot
legendBarplot
Documented in
annotationBarplot
barplotLatticeCounts
barplotLatticeFraction
legendBarplot
#' add legend to AllelicImbalance barplot
#'
#' adds a very customizable legend function for AllelicImbalance barplots.
#'
#' the function is preferably called from within the AllelicImbalance barplot method.
#'
#'
#' @param lowerLeftCorner position of the plot to add legend to (default c(0,0))
#' @param size scale the plot, default is 1
#' @param rownames rownames in legend
#' @param colnames colnames in legend
#' @param boxsize size of each box fill
#' @param boxspace space inbetween the box fill
#' @param fgCol color for allele1
#' @param bgCol color for allele2
#' @param ylegendPos placement of the legend within the plot for y
#' @param xlegendPos placement of the legend within the plot for x
#' @param cex size of legend text
#' @author Jesper R. Gadin
#' @keywords legend barplot
#' @examples
#'
#' #code placeholders
#' #< create a barplot with legend >
#' #< add legend >
#'
#' @export legendBarplot
legendBarplot <- function(lowerLeftCorner, size, rownames, colnames, boxsize=1, boxspace=1,fgCol,bgCol,
ylegendPos=1, xlegendPos=0.96, cex=1){
cex.legend <- cex
#first fill/box
x = lowerLeftCorner[1] + size[1] * seq(xlegendPos, (xlegendPos -
(0.02 * boxspace * (length(unique(fgCol)) - 1))),
length = length(unique(fgCol)))
y = (lowerLeftCorner[2] + size[2] * (ylegendPos + 0.02 * boxspace)) * rep(1,
length(unique(fgCol)))
squares = rep(c(size[1] * 0.012 * boxsize), length(unique(fgCol)))
symbols(x=x, y = y , bg = unique(fgCol), squares = squares, add = TRUE,
inches = FALSE,xpd=TRUE)
if(length(rownames)==2){
#second fill/box
x = lowerLeftCorner[1] + size[1] * seq(xlegendPos, (xlegendPos -
(0.02 * boxspace * (length(unique(bgCol)) - 1))),
length = length(unique(bgCol)))
y=(lowerLeftCorner[2] + size[2] * 1) * rep(ylegendPos, length(unique(bgCol)))
squares=rep(c(size[1] * 0.012 * boxsize), length(unique(bgCol)))
symbols(x=x, y = y , bg = unique(bgCol), squares = squares, add = TRUE,
inches = FALSE,xpd=TRUE)
}
# row-lab
if(length(rownames)==2){
x = c(lowerLeftCorner[1] + (size[1] * (c(xlegendPos, xlegendPos)+0.02 * boxspace)))
y = lowerLeftCorner[2] + (size[2] * c(ylegendPos+(0.02 * boxspace), 1))
text(x=x,
y = y, rownames,
srt = 0, cex = cex.legend, adj = c(0, 0.5), xpd = TRUE)
}else if(length(rownames)==1){
x = c(lowerLeftCorner[1] + (size[1] * (c(xlegendPos)+0.02 * boxspace)))
y = lowerLeftCorner[2] + (size[2] * c(ylegendPos+(0.02 * boxspace)))
text(x=x,
y = y, rownames,
srt = 0, cex = cex.legend, adj = c(0, 0.5), xpd = TRUE)
}
# col-lab
x = lowerLeftCorner[1] + size[1] * seq(xlegendPos, (xlegendPos - ((0.02 * boxspace) *
(length(unique(fgCol)) - 1))), length = length(unique(fgCol)))
y = lowerLeftCorner[2] + size[2] * (ylegendPos+0.03*boxspace)
text(x=x,
y = y, colnames,
srt = 90, cex = cex.legend, adj = c(0, 0.5), xpd = TRUE)
}
#' add annotation to AllelicImbalance barplot
#'
#' adds a customizable annotation functionality for AllelicImbalance barplots.
#'
#' the function is preferably called from within the AllelicImbalance barplot method.
#'
#'
#' @param strand strand, "+", "-", "*" or "both"
#' @param snp integer for the described snp
#' @param lowerLeftCorner position of the plot to add legend to (default c(0,0))
#' @param annDfPlus annotation dataframe plus strand
#' @param annDfMinus annotation dataframe minus strand
#' @param cex size of annotation text
#' @param ypos relative y-axis position for the annotation text
#' @param interspace space between each annotation block
#' @author Jesper R. Gadin
#' @keywords annotation barplot
#' @examples
#'
#' #code placeholders
#' #< create a barplot without annotation >
#' #< add annotation >
#'
#' @export annotationBarplot
annotationBarplot <- function(strand,snp, lowerLeftCorner, annDfPlus, annDfMinus,
cex=0.7, ypos=0, interspace=1){
i <- snp
#ypos, is relative to the default
# check which columns to extract
dfType <- c("symbol", "exon_id", "tx_id", "cds_id")
TFann <- (dfType %in% colnames(annDfPlus)) | (dfType %in% colnames(annDfMinus))
if (strand == "+" | strand == "-" | strand == "*" ) {
# placed on left side
if (strand == "+" | strand == "*" ) {
df <- annDfPlus[, TFann, drop = FALSE]
yPosTmp <- lowerLeftCorner[2] + (1.03) + ypos
text <- paste("Plus-strand")
text(x = lowerLeftCorner[1] + 0.01, y = yPosTmp, labels = text,
adj = 0, xpd = TRUE, cex=cex)
yPosTmp <- yPosTmp - (0.03*interspace)
for (j in 1:length(colnames(df))) {
text <- paste(colnames(df)[j], df[i, j], sep = ": ")
text(x = lowerLeftCorner[1] + 0.01, y = yPosTmp, labels = text,
adj = 0, xpd = TRUE, cex=cex)
yPosTmp <- yPosTmp - (0.02*interspace)
}
}
# placed on left side
if (strand == "-" & (!strand == "*" )) {
df <- annDfMinus[, TFann, drop = FALSE]
yPosTmp <- lowerLeftCorner[2] + (1.03) + ypos
text <- paste("Minus-strand")
text(x = lowerLeftCorner[1] + 0.01, y = yPosTmp, labels = text,
adj = 0, xpd = TRUE, cex=cex)
yPosTmp <- yPosTmp - (0.03*interspace)
for (j in 1:length(colnames(df))) {
text <- paste(colnames(df)[j], df[i, j], sep = ": ")
text(x = lowerLeftCorner[1] + 0.01, y = yPosTmp, labels = text,
adj = 0, xpd = TRUE, cex=cex)
yPosTmp <- yPosTmp - (0.02*interspace)
}
}
# placed on right side
if (strand == "*" ) {
df <- annDfMinus[, TFann, drop = FALSE]
yPosTmp <- lowerLeftCorner[2] + (1.03) + ypos
text <- paste("Minus-strand")
text(x = lowerLeftCorner[1] + 1, y = yPosTmp, labels = text,
adj = 0.95, xpd = TRUE, cex=cex)
yPosTmp <- yPosTmp - (0.03*interspace)
for (j in 1:length(colnames(df))) {
text <- paste(df[i, j], colnames(df)[j], sep = " :")
text(x = lowerLeftCorner[1] + 1, y = yPosTmp, labels = text,
adj = 0.95, xpd = TRUE, cex=cex)
yPosTmp <- yPosTmp - (0.02*interspace)
}
}
########
# Dual barplot
########
}else if (strand == "both") {
# plus strand (over)
df <- annDfPlus[, TFann, drop = FALSE]
yPosTmp <- lowerLeftCorner[2] + (1.01) + ypos
for (j in 1:length(colnames(df))) {
text <- paste(colnames(df)[j], df[i, j], sep = ": ")
text(x = lowerLeftCorner[1] + 0.01, y = yPosTmp, labels = text,
adj = 0, cex=cex)
yPosTmp <- yPosTmp - (0.02*interspace)
}
# minus strand (under)
df <- annDfMinus[, TFann, drop = FALSE]
yPosTmp <- lowerLeftCorner[2] - (0.01) + ypos
for (j in 1:length(colnames(df))) {
text <- paste(colnames(df)[j], df[i, j], sep = ": ")
text(x = lowerLeftCorner[1] + 0.01, y = yPosTmp, labels = text,
adj = 0, cex=cex)
yPosTmp <- yPosTmp + (0.02*interspace)
}
}
}
#' lattice barplot inner functions for ASEset objects
#'
#' Generates lattice barplots for ASEset objects. Two levels of plotting detail
#' are provided: a detailed barplot of read counts by allele useful for fewer
#' samples and SNPs, and a less detailed barplot of the fraction of imbalance,
#' useful for more samples and SNPs.
#'
#' \code{filter.pValue.fraction} is intended to remove p-value annotation with
#' very large difference in frequency, which could just be a sequencing
#' mistake. This is to avoid p-values like 1e-235 or similar.
#'
#' \code{sampleColour}User specified colours, either given as named colours
#' ('red', 'blue', etc) or as hexadecimal code. Can be either length 1 for all
#' samples, or else of a length corresponding to the number of samples for
#' individual colouring.
#'
#' @name barplot-lattice-support
#' @rdname barplot-lattice-support
#' @aliases barplot-lattice-support barplotLatticeCounts barplotLatticeFraction
#' @param identifier, the single snp name to plot
#' @param ... used to pass on variables
#' @author Jesper R. Gadin, Lasse Folkersen
#' @seealso \itemize{ \item The \code{\link{ASEset}} class which the barplot
#' function can be called up on. }
#' @keywords barplot
#' @examples
#'
#' a <- ASEset
#' name <- rownames(a)[1]
#'
#' barplotLatticeFraction(identifier=name, x=a, astrand="+")
#' barplotLatticeCounts(identifier=name, x=a, astrand="+")
#'
#' @export barplotLatticeFraction
#' @export barplotLatticeCounts
#'
NULL
#' @rdname barplot-lattice-support
barplotLatticeFraction <- function(identifier, ...) {
if (length(list(...)) == 0) {
e <- new.env(hash = TRUE)
} else {
e <- list2env(list(...))
}
e$ids <- unlist(e$ids)
e$strand <- e$astrand
if (!exists("mainvec", envir = e, inherits = FALSE)) {
e$mainvec <- rep("",nrow(e$x))
}
if(class(e$mainvec)=="list"){
e$mainvec <- unlist(e$mainvec)
}
if (!exists("cex.mainvec", envir = e, inherits = FALSE)) {
e$cex.mainvec <- 1
}
if (!exists("main", envir = e, inherits = FALSE)) {
e$main <- e$mainvec[e$ids %in% identifier]
}
if (!exists("deAnnoPlot", envir = e, inherits = FALSE)) {
e$deAnnoPlot <- FALSE
}
if (!exists("ylab", envir = e, inherits = FALSE)) {
e$ylab <- ""
}
if (!exists("xlab", envir = e, inherits = FALSE)) {
e$xlab <- ""
}
if (!exists("middleLine", envir = e, inherits = FALSE)) {
e$middleLine <- TRUE
}
if (!exists("top.fraction.criteria", envir = e, inherits = FALSE)) {
e$top.fraction.criteria <- "maxcount"
}
df <- fractionPlotDf(e$x, identifier, strand=e$strand, top.fraction.criteria=e$top.fraction.criteria)
# Grah params
my_cols <- c("green", "red")
# set default values
parset <- list(superpose.polygon=list(col=my_cols))
scales = list(rot = c(90, 0))
if (e$deAnnoPlot) {
parset <- list(
layout.widths = list(
left.padding = 0,
axis.left = 0,
ylab.axis.padding = 0,
right.padding = 0,
axis.right = 0
),
layout.heights = list(
top.padding = 0.1,
between = 0.1,
xlab.top= 0.1,
axis.top = 0,
main=1.1,
main.key.padding=1,
axis.xlab.padding = 1,
bottom.padding = 1,
axis.bottom = 0.3
),
superpose.polygon=list(col=my_cols)
)
scales = list(y = list(at = NULL, labels = NULL),
x = list(labels = rep("",ncol(e$x)))
)
#, rot = c(90, 0))
}
if(e$top.fraction.criteria=="phase"){
groups <- df$phase
df$groups <- groups
}else{
groups <- df$alleles
df$groups <- groups
}
if(!e$middleLine) {
b <- barchart(values ~ sample, group = groups, data = df, origin = 0,
stack = TRUE, scales = scales,
main = list(label=e$main, cex=e$cex.mainvec),
ylab = e$ylab, xlab = e$xlab,
par.settings = parset)
}else if (e$middleLine) {
b <- barchart(values ~ sample, group = groups, data = df, origin = 0,
stack = TRUE, scales = scales,
main = list(label=e$main, cex=e$cex.mainvec),
ylab = e$ylab, xlab = e$xlab,
par.settings = parset, panel=function(x, y, ...) {
panel.barchart(x, y, ...)
panel.abline(h=0.5, lty=1)
} )
}else {
stop("middleLine has to be TRUE or FALSE")
}
b
}
#' @rdname barplot-lattice-support
barplotLatticeCounts <- function(identifier, ...) {
#null out a variable later used in a lattice plot
#read here why: http://stackoverflow.com/questions/9439256/how-can-i-handle-r-cmd-check-no-visible-binding-for-global-variable-notes-when
alleles <- NULL
if (length(list(...)) == 0) {
e <- new.env(hash = TRUE)
} else {
e <- list2env(list(...))
}
#use requested strand instead of Gviz ranges strand
e$strand <- e$astrand
e$ids <- unlist(e$ids)
#e$auto.key <- list(points = FALSE, rectangles = TRUE, space = "top", size = 2,
# cex = 0.8)
if (!exists("mainvec", envir = e, inherits = FALSE)) {
e$mainvec <- rep("",nrow(e$x))
}
if(class(e$mainvec)=="list"){
e$mainvec <- unlist(e$mainvec)
}
if (!exists("main", envir = e, inherits = FALSE)) {
e$main <- e$mainvec[e$ids %in% identifier]
#print(identifier)
#print(e$ids)
#print(e$main)
#print(e$mainvec[which(e$ids %in% identifier)])
#print(e$mainvec)
#print(which(e$ids %in% identifier))
}
if (!exists("deAnnoPlot", envir = e, inherits = FALSE)) {
e$deAnnoPlot <- FALSE
}
if (!exists("ylab", envir = e, inherits = FALSE)) {
e$ylab <- ""
}
if (!exists("xlab", envir = e, inherits = FALSE)) {
e$xlab <- ""
}
### Grah params set default values
parset <- list()
scales = list(rot = c(90, 0))
makePlotDf <- function(strand){
acounts<- alleleCounts(e$x, strand = strand)
arank<- arank(e$x, strand = "*")
#afraction<- fraction(e$x, strand = strand)
#amainVec<- e$amainVec
# prepare data to be plotted
#a.m <- amainVec[identifier]
a.r <- arank[[identifier]][1:2]
a.c <- acounts[[identifier]][, a.r, drop = FALSE]
values <- as.vector(t(a.c))
sample <- vector()
for (i in 1:nrow(a.c)) {
sample <- c(sample, rownames(a.c)[i], rownames(a.c)[i])
}
if(strand=="-" && e$strand=="both"){
values <- -values
}
alleles <- rep(colnames(a.c), nrow(a.c))
df <- data.frame(values = values, sample = sample, alleles = alleles)
# to get right order in barchart
df$sample <- factor(df$sample, levels = unique(df$sample))
df
}
if(e$strand %in% c("+","-","*")){
df <- makePlotDf(strand=e$strand)
if (e$deAnnoPlot) {
e$auto.key <- FALSE
parset <- list(
layout.widths = list(
left.padding = 0,
axis.left = 0,
ylab.axis.padding = 0,
right.padding = 0,
axis.right = 0
),
layout.heights = list(
top.padding = 0.1,
between = 0.1,
xlab.top= 0.1,
axis.top = 0,
main=1.1,
main.key.padding=1,
axis.xlab.padding = 1,
bottom.padding = 1,
axis.bottom = 0.3
)
)
scales = list(y = list(at = NULL, labels = NULL), rot = c(90, 0), auto.key = e$auto.key)
}
b <- barchart(values ~ sample, horiz = FALSE, origin = 0, group = alleles, data = df,
stack = FALSE, scales = scales, ylab = e$ylab, xlab = e$xlab,
box.ratio = 2, abbreviate = TRUE, par.settings = parset, main = e$main )
}else if(e$strand=="both"){
df <- rbind(makePlotDf(strand="+"),makePlotDf(strand="-"))
if (e$deAnnoPlot) {
e$auto.key <- FALSE
parset <- list(
layout.widths = list(
left.padding = 0,
axis.left = 0,
ylab.axis.padding = 0,
right.padding = 0,
axis.right = 0
),
layout.heights = list(
top.padding = 0.1,
between = 0.1,
xlab.top= 0.1,
axis.top = 0,
main=1.1,
main.key.padding=1,
axis.xlab.padding = 1,
bottom.padding = 1,
axis.bottom = 0.3
)
)
scales = list(y = list(at = NULL, labels = NULL), rot = c(90, 0), auto.key = e$auto.key)
}
b <- barchart(values ~ sample, horiz = FALSE, origin = 0, group = alleles, data = df,
stack = FALSE, scales = scales, ylab = e$ylab, xlab = e$xlab,
box.ratio = 2, abbreviate = TRUE, par.settings = parset, main = e$main)
}else {
stop("strand must be + - * or both")
}
b
}
Try the AllelicImbalance package in your browser
Any scripts or data that you put into this service are public.
AllelicImbalance documentation built on Nov. 8, 2020, 6:52 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 barplotLatticeCounts barplotLatticeFraction annotationBarplot legendBarplot
Documented in annotationBarplot barplotLatticeCounts barplotLatticeFraction legendBarplot
#' add legend to AllelicImbalance barplot
#'
#' adds a very customizable legend function for AllelicImbalance barplots.
#'
#' the function is preferably called from within the AllelicImbalance barplot method.
#'
#'
#' @param lowerLeftCorner position of the plot to add legend to (default c(0,0))
#' @param size scale the plot, default is 1
#' @param rownames rownames in legend
#' @param colnames colnames in legend
#' @param boxsize size of each box fill
#' @param boxspace space inbetween the box fill
#' @param fgCol color for allele1
#' @param bgCol color for allele2
#' @param ylegendPos placement of the legend within the plot for y
#' @param xlegendPos placement of the legend within the plot for x
#' @param cex size of legend text
#' @author Jesper R. Gadin
#' @keywords legend barplot
#' @examples
#'
#' #code placeholders
#' #< create a barplot with legend >
#' #< add legend >
#'
#' @export legendBarplot
legendBarplot <- function(lowerLeftCorner, size, rownames, colnames, boxsize=1, boxspace=1,fgCol,bgCol,
ylegendPos=1, xlegendPos=0.96, cex=1){
cex.legend <- cex
#first fill/box
x = lowerLeftCorner[1] + size[1] * seq(xlegendPos, (xlegendPos -
(0.02 * boxspace * (length(unique(fgCol)) - 1))),
length = length(unique(fgCol)))
y = (lowerLeftCorner[2] + size[2] * (ylegendPos + 0.02 * boxspace)) * rep(1,
length(unique(fgCol)))
squares = rep(c(size[1] * 0.012 * boxsize), length(unique(fgCol)))
symbols(x=x, y = y , bg = unique(fgCol), squares = squares, add = TRUE,
inches = FALSE,xpd=TRUE)
if(length(rownames)==2){
#second fill/box
x = lowerLeftCorner[1] + size[1] * seq(xlegendPos, (xlegendPos -
(0.02 * boxspace * (length(unique(bgCol)) - 1))),
length = length(unique(bgCol)))
y=(lowerLeftCorner[2] + size[2] * 1) * rep(ylegendPos, length(unique(bgCol)))
squares=rep(c(size[1] * 0.012 * boxsize), length(unique(bgCol)))
symbols(x=x, y = y , bg = unique(bgCol), squares = squares, add = TRUE,
inches = FALSE,xpd=TRUE)
}
# row-lab
if(length(rownames)==2){
x = c(lowerLeftCorner[1] + (size[1] * (c(xlegendPos, xlegendPos)+0.02 * boxspace)))
y = lowerLeftCorner[2] + (size[2] * c(ylegendPos+(0.02 * boxspace), 1))
text(x=x,
y = y, rownames,
srt = 0, cex = cex.legend, adj = c(0, 0.5), xpd = TRUE)
}else if(length(rownames)==1){
x = c(lowerLeftCorner[1] + (size[1] * (c(xlegendPos)+0.02 * boxspace)))
y = lowerLeftCorner[2] + (size[2] * c(ylegendPos+(0.02 * boxspace)))
text(x=x,
y = y, rownames,
srt = 0, cex = cex.legend, adj = c(0, 0.5), xpd = TRUE)
}
# col-lab
x = lowerLeftCorner[1] + size[1] * seq(xlegendPos, (xlegendPos - ((0.02 * boxspace) *
(length(unique(fgCol)) - 1))), length = length(unique(fgCol)))
y = lowerLeftCorner[2] + size[2] * (ylegendPos+0.03*boxspace)
text(x=x,
y = y, colnames,
srt = 90, cex = cex.legend, adj = c(0, 0.5), xpd = TRUE)
}
#' add annotation to AllelicImbalance barplot
#'
#' adds a customizable annotation functionality for AllelicImbalance barplots.
#'
#' the function is preferably called from within the AllelicImbalance barplot method.
#'
#'
#' @param strand strand, "+", "-", "*" or "both"
#' @param snp integer for the described snp
#' @param lowerLeftCorner position of the plot to add legend to (default c(0,0))
#' @param annDfPlus annotation dataframe plus strand
#' @param annDfMinus annotation dataframe minus strand
#' @param cex size of annotation text
#' @param ypos relative y-axis position for the annotation text
#' @param interspace space between each annotation block
#' @author Jesper R. Gadin
#' @keywords annotation barplot
#' @examples
#'
#' #code placeholders
#' #< create a barplot without annotation >
#' #< add annotation >
#'
#' @export annotationBarplot
annotationBarplot <- function(strand,snp, lowerLeftCorner, annDfPlus, annDfMinus,
cex=0.7, ypos=0, interspace=1){
i <- snp
#ypos, is relative to the default
# check which columns to extract
dfType <- c("symbol", "exon_id", "tx_id", "cds_id")
TFann <- (dfType %in% colnames(annDfPlus)) | (dfType %in% colnames(annDfMinus))
if (strand == "+" | strand == "-" | strand == "*" ) {
# placed on left side
if (strand == "+" | strand == "*" ) {
df <- annDfPlus[, TFann, drop = FALSE]
yPosTmp <- lowerLeftCorner[2] + (1.03) + ypos
text <- paste("Plus-strand")
text(x = lowerLeftCorner[1] + 0.01, y = yPosTmp, labels = text,
adj = 0, xpd = TRUE, cex=cex)
yPosTmp <- yPosTmp - (0.03*interspace)
for (j in 1:length(colnames(df))) {
text <- paste(colnames(df)[j], df[i, j], sep = ": ")
text(x = lowerLeftCorner[1] + 0.01, y = yPosTmp, labels = text,
adj = 0, xpd = TRUE, cex=cex)
yPosTmp <- yPosTmp - (0.02*interspace)
}
}
# placed on left side
if (strand == "-" & (!strand == "*" )) {
df <- annDfMinus[, TFann, drop = FALSE]
yPosTmp <- lowerLeftCorner[2] + (1.03) + ypos
text <- paste("Minus-strand")
text(x = lowerLeftCorner[1] + 0.01, y = yPosTmp, labels = text,
adj = 0, xpd = TRUE, cex=cex)
yPosTmp <- yPosTmp - (0.03*interspace)
for (j in 1:length(colnames(df))) {
text <- paste(colnames(df)[j], df[i, j], sep = ": ")
text(x = lowerLeftCorner[1] + 0.01, y = yPosTmp, labels = text,
adj = 0, xpd = TRUE, cex=cex)
yPosTmp <- yPosTmp - (0.02*interspace)
}
}
# placed on right side
if (strand == "*" ) {
df <- annDfMinus[, TFann, drop = FALSE]
yPosTmp <- lowerLeftCorner[2] + (1.03) + ypos
text <- paste("Minus-strand")
text(x = lowerLeftCorner[1] + 1, y = yPosTmp, labels = text,
adj = 0.95, xpd = TRUE, cex=cex)
yPosTmp <- yPosTmp - (0.03*interspace)
for (j in 1:length(colnames(df))) {
text <- paste(df[i, j], colnames(df)[j], sep = " :")
text(x = lowerLeftCorner[1] + 1, y = yPosTmp, labels = text,
adj = 0.95, xpd = TRUE, cex=cex)
yPosTmp <- yPosTmp - (0.02*interspace)
}
}
########
# Dual barplot
########
}else if (strand == "both") {
# plus strand (over)
df <- annDfPlus[, TFann, drop = FALSE]
yPosTmp <- lowerLeftCorner[2] + (1.01) + ypos
for (j in 1:length(colnames(df))) {
text <- paste(colnames(df)[j], df[i, j], sep = ": ")
text(x = lowerLeftCorner[1] + 0.01, y = yPosTmp, labels = text,
adj = 0, cex=cex)
yPosTmp <- yPosTmp - (0.02*interspace)
}
# minus strand (under)
df <- annDfMinus[, TFann, drop = FALSE]
yPosTmp <- lowerLeftCorner[2] - (0.01) + ypos
for (j in 1:length(colnames(df))) {
text <- paste(colnames(df)[j], df[i, j], sep = ": ")
text(x = lowerLeftCorner[1] + 0.01, y = yPosTmp, labels = text,
adj = 0, cex=cex)
yPosTmp <- yPosTmp + (0.02*interspace)
}
}
}
#' lattice barplot inner functions for ASEset objects
#'
#' Generates lattice barplots for ASEset objects. Two levels of plotting detail
#' are provided: a detailed barplot of read counts by allele useful for fewer
#' samples and SNPs, and a less detailed barplot of the fraction of imbalance,
#' useful for more samples and SNPs.
#'
#' \code{filter.pValue.fraction} is intended to remove p-value annotation with
#' very large difference in frequency, which could just be a sequencing
#' mistake. This is to avoid p-values like 1e-235 or similar.
#'
#' \code{sampleColour}User specified colours, either given as named colours
#' ('red', 'blue', etc) or as hexadecimal code. Can be either length 1 for all
#' samples, or else of a length corresponding to the number of samples for
#' individual colouring.
#'
#' @name barplot-lattice-support
#' @rdname barplot-lattice-support
#' @aliases barplot-lattice-support barplotLatticeCounts barplotLatticeFraction
#' @param identifier, the single snp name to plot
#' @param ... used to pass on variables
#' @author Jesper R. Gadin, Lasse Folkersen
#' @seealso \itemize{ \item The \code{\link{ASEset}} class which the barplot
#' function can be called up on. }
#' @keywords barplot
#' @examples
#'
#' a <- ASEset
#' name <- rownames(a)[1]
#'
#' barplotLatticeFraction(identifier=name, x=a, astrand="+")
#' barplotLatticeCounts(identifier=name, x=a, astrand="+")
#'
#' @export barplotLatticeFraction
#' @export barplotLatticeCounts
#'
NULL
#' @rdname barplot-lattice-support
barplotLatticeFraction <- function(identifier, ...) {
if (length(list(...)) == 0) {
e <- new.env(hash = TRUE)
} else {
e <- list2env(list(...))
}
e$ids <- unlist(e$ids)
e$strand <- e$astrand
if (!exists("mainvec", envir = e, inherits = FALSE)) {
e$mainvec <- rep("",nrow(e$x))
}
if(class(e$mainvec)=="list"){
e$mainvec <- unlist(e$mainvec)
}
if (!exists("cex.mainvec", envir = e, inherits = FALSE)) {
e$cex.mainvec <- 1
}
if (!exists("main", envir = e, inherits = FALSE)) {
e$main <- e$mainvec[e$ids %in% identifier]
}
if (!exists("deAnnoPlot", envir = e, inherits = FALSE)) {
e$deAnnoPlot <- FALSE
}
if (!exists("ylab", envir = e, inherits = FALSE)) {
e$ylab <- ""
}
if (!exists("xlab", envir = e, inherits = FALSE)) {
e$xlab <- ""
}
if (!exists("middleLine", envir = e, inherits = FALSE)) {
e$middleLine <- TRUE
}
if (!exists("top.fraction.criteria", envir = e, inherits = FALSE)) {
e$top.fraction.criteria <- "maxcount"
}
df <- fractionPlotDf(e$x, identifier, strand=e$strand, top.fraction.criteria=e$top.fraction.criteria)
# Grah params
my_cols <- c("green", "red")
# set default values
parset <- list(superpose.polygon=list(col=my_cols))
scales = list(rot = c(90, 0))
if (e$deAnnoPlot) {
parset <- list(
layout.widths = list(
left.padding = 0,
axis.left = 0,
ylab.axis.padding = 0,
right.padding = 0,
axis.right = 0
),
layout.heights = list(
top.padding = 0.1,
between = 0.1,
xlab.top= 0.1,
axis.top = 0,
main=1.1,
main.key.padding=1,
axis.xlab.padding = 1,
bottom.padding = 1,
axis.bottom = 0.3
),
superpose.polygon=list(col=my_cols)
)
scales = list(y = list(at = NULL, labels = NULL),
x = list(labels = rep("",ncol(e$x)))
)
#, rot = c(90, 0))
}
if(e$top.fraction.criteria=="phase"){
groups <- df$phase
df$groups <- groups
}else{
groups <- df$alleles
df$groups <- groups
}
if(!e$middleLine) {
b <- barchart(values ~ sample, group = groups, data = df, origin = 0,
stack = TRUE, scales = scales,
main = list(label=e$main, cex=e$cex.mainvec),
ylab = e$ylab, xlab = e$xlab,
par.settings = parset)
}else if (e$middleLine) {
b <- barchart(values ~ sample, group = groups, data = df, origin = 0,
stack = TRUE, scales = scales,
main = list(label=e$main, cex=e$cex.mainvec),
ylab = e$ylab, xlab = e$xlab,
par.settings = parset, panel=function(x, y, ...) {
panel.barchart(x, y, ...)
panel.abline(h=0.5, lty=1)
} )
}else {
stop("middleLine has to be TRUE or FALSE")
}
b
}
#' @rdname barplot-lattice-support
barplotLatticeCounts <- function(identifier, ...) {
#null out a variable later used in a lattice plot
#read here why: http://stackoverflow.com/questions/9439256/how-can-i-handle-r-cmd-check-no-visible-binding-for-global-variable-notes-when
alleles <- NULL
if (length(list(...)) == 0) {
e <- new.env(hash = TRUE)
} else {
e <- list2env(list(...))
}
#use requested strand instead of Gviz ranges strand
e$strand <- e$astrand
e$ids <- unlist(e$ids)
#e$auto.key <- list(points = FALSE, rectangles = TRUE, space = "top", size = 2,
# cex = 0.8)
if (!exists("mainvec", envir = e, inherits = FALSE)) {
e$mainvec <- rep("",nrow(e$x))
}
if(class(e$mainvec)=="list"){
e$mainvec <- unlist(e$mainvec)
}
if (!exists("main", envir = e, inherits = FALSE)) {
e$main <- e$mainvec[e$ids %in% identifier]
#print(identifier)
#print(e$ids)
#print(e$main)
#print(e$mainvec[which(e$ids %in% identifier)])
#print(e$mainvec)
#print(which(e$ids %in% identifier))
}
if (!exists("deAnnoPlot", envir = e, inherits = FALSE)) {
e$deAnnoPlot <- FALSE
}
if (!exists("ylab", envir = e, inherits = FALSE)) {
e$ylab <- ""
}
if (!exists("xlab", envir = e, inherits = FALSE)) {
e$xlab <- ""
}
### Grah params set default values
parset <- list()
scales = list(rot = c(90, 0))
makePlotDf <- function(strand){
acounts<- alleleCounts(e$x, strand = strand)
arank<- arank(e$x, strand = "*")
#afraction<- fraction(e$x, strand = strand)
#amainVec<- e$amainVec
# prepare data to be plotted
#a.m <- amainVec[identifier]
a.r <- arank[[identifier]][1:2]
a.c <- acounts[[identifier]][, a.r, drop = FALSE]
values <- as.vector(t(a.c))
sample <- vector()
for (i in 1:nrow(a.c)) {
sample <- c(sample, rownames(a.c)[i], rownames(a.c)[i])
}
if(strand=="-" && e$strand=="both"){
values <- -values
}
alleles <- rep(colnames(a.c), nrow(a.c))
df <- data.frame(values = values, sample = sample, alleles = alleles)
# to get right order in barchart
df$sample <- factor(df$sample, levels = unique(df$sample))
df
}
if(e$strand %in% c("+","-","*")){
df <- makePlotDf(strand=e$strand)
if (e$deAnnoPlot) {
e$auto.key <- FALSE
parset <- list(
layout.widths = list(
left.padding = 0,
axis.left = 0,
ylab.axis.padding = 0,
right.padding = 0,
axis.right = 0
),
layout.heights = list(
top.padding = 0.1,
between = 0.1,
xlab.top= 0.1,
axis.top = 0,
main=1.1,
main.key.padding=1,
axis.xlab.padding = 1,
bottom.padding = 1,
axis.bottom = 0.3
)
)
scales = list(y = list(at = NULL, labels = NULL), rot = c(90, 0), auto.key = e$auto.key)
}
b <- barchart(values ~ sample, horiz = FALSE, origin = 0, group = alleles, data = df,
stack = FALSE, scales = scales, ylab = e$ylab, xlab = e$xlab,
box.ratio = 2, abbreviate = TRUE, par.settings = parset, main = e$main )
}else if(e$strand=="both"){
df <- rbind(makePlotDf(strand="+"),makePlotDf(strand="-"))
if (e$deAnnoPlot) {
e$auto.key <- FALSE
parset <- list(
layout.widths = list(
left.padding = 0,
axis.left = 0,
ylab.axis.padding = 0,
right.padding = 0,
axis.right = 0
),
layout.heights = list(
top.padding = 0.1,
between = 0.1,
xlab.top= 0.1,
axis.top = 0,
main=1.1,
main.key.padding=1,
axis.xlab.padding = 1,
bottom.padding = 1,
axis.bottom = 0.3
)
)
scales = list(y = list(at = NULL, labels = NULL), rot = c(90, 0), auto.key = e$auto.key)
}
b <- barchart(values ~ sample, horiz = FALSE, origin = 0, group = alleles, data = df,
stack = FALSE, scales = scales, ylab = e$ylab, xlab = e$xlab,
box.ratio = 2, abbreviate = TRUE, par.settings = parset, main = e$main)
}else {
stop("strand must be + - * or both")
}
b
}
Try the AllelicImbalance package in your browser
Any scripts or data that you put into this service are public.
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.