Nothing
convertHeight2NPCnum <- function(.ele){
if(is(.ele, "unit")){
return(convertHeight(.ele, unitTo="npc", valueOnly=TRUE))
}else{
if(is.list(.ele)){
.ele <- sapply(.ele, function(.e){
if(is(.e, "unit")){
.e <- convertHeight(.e, unitTo="npc", valueOnly=TRUE)
}
.e[1]
})
return(unlist(.ele))
}else{
if(is.numeric(.ele)){
return(.ele)
}else{
if(is.integer(.ele)){
return(.ele)
}else{
return(.ele)
}
}
}
}
}
plotFeatures <- function(feature.splited, LINEH, bottomHeight){
feature.height <- 0
for(n in 1:length(feature.splited)){
this.feature.height <-
max(c(feature.splited[[n]]$height/2,
.0001)) + 0.2 * LINEH
feature.height <- feature.height + this.feature.height
##baseline
grid.lines(x=c(0, 1), y=c(bottomHeight+feature.height,
bottomHeight+feature.height))
for(m in 1:length(feature.splited[[n]])){
this.dat <- feature.splited[[n]][m]
color <- if(is.list(this.dat$color)) this.dat$color[[1]] else
this.dat$color
if(length(color)==0) color <- "black"
fill <- if(is.list(this.dat$fill)) this.dat$fill[[1]] else
this.dat$fill
if(length(fill)==0) fill <- "white"
this.cex <- if(length(this.dat$cex)>0) this.dat$cex[[1]][1] else 1
lwd <- if(length(this.dat$lwd)>0) this.dat$lwd[[1]][1] else 1
this.feature.height.m <-
if(length(this.dat$height)>0)
this.dat$height[[1]][1] else
2*this.feature.height
grid.rect(x=start(this.dat)-.1, y=bottomHeight+feature.height,
width=width(this.dat)-.8,
height=this.feature.height.m,
just="left", gp=gpar(col=color, fill=fill, lwd=lwd),
default.units = "native")
}
feature.height <- feature.height + this.feature.height
}
feature.height
}
plotLollipops <- function(SNPs, feature.height, bottomHeight, baseline,
type, ranges, yaxis, yaxis.gp, scoreMax, scoreMax0, scoreType,
LINEW, cex, ratio.yx, GAP, pin, dashline.col,
side=c("top", "bottom"), jitter=c("node", "label"),
main=TRUE){
side <- match.arg(side)
jitter <- match.arg(jitter)
if(side=="top"){
pushViewport(viewport(y=bottomHeight,
height=1,
just="bottom",
xscale=c(start(ranges),
end(ranges)),
clip="off"))
}else{
pushViewport(viewport(y=bottomHeight+feature.height,
height=1,
just="top",
xscale=c(start(ranges),
end(ranges)),
yscale=c(1, 0),
clip="off"))
}
if(type=="pie.stack" && length(SNPs$stack.factor)>0){
stopifnot(is.vector(SNPs$stack.factor, mode="character"))
if(length(SNPs$stack.factor.order)>0 ||
length(SNPs$stack.factor.first)>0){
warning("stack.factor.order and stack.factor.first are used by this function!",
"The values in these column will be removed.")
}
## condense the SNPs
stack.factors <- unique(as.character(SNPs$stack.factor))
stack.factors <- sort(stack.factors)
stack.factors.order <- 1:length(stack.factors)
names(stack.factors.order) <- stack.factors
SNPs <- SNPs[order(as.character(seqnames(SNPs)), start(SNPs),
as.character(SNPs$stack.factor))]
SNPs$stack.factor.order <- stack.factors.order[SNPs$stack.factor]
SNPs$stack.factor.first <- !duplicated(SNPs)
SNPs.condense <- SNPs
SNPs.condense$oid <- 1:length(SNPs)
SNPs.condense$factor <- paste(as.character(seqnames(SNPs)), start(SNPs), end(SNPs))
SNPs.condense <- split(SNPs.condense, SNPs.condense$factor)
SNPs.condense <- lapply(SNPs.condense, function(.ele){
.oid <- .ele$oid
.gr <- .ele[1]
mcols(.gr) <- NULL
.gr$oid <- NumericList(.oid)
.gr
})
SNPs.condense <- unlist(GRangesList(SNPs.condense), use.names = FALSE)
SNPs.condense <- sort(SNPs.condense)
lab.pos.condense <- jitterLables(start(SNPs.condense),
xscale=c(start(ranges), end(ranges)),
lineW=LINEW*cex)
lab.pos.condense <- reAdjustLabels(lab.pos.condense,
lineW=LINEW*cex)
condense.ids <- SNPs.condense$oid
lab.pos <- rep(lab.pos.condense, elementNROWS(condense.ids))
lab.pos <- lab.pos[order(unlist(condense.ids))]
}else{
lab.pos <- jitterLables(start(SNPs),
xscale=c(start(ranges), end(ranges)),
lineW=LINEW*cex)
lab.pos <- reAdjustLabels(lab.pos,
lineW=LINEW*cex)
}
if(length(SNPs)>0){
yaxisat <- NULL
yaxisLabel <- TRUE
if(length(yaxis)>1 && is.numeric(yaxis)){
yaxisat <- yaxis
if(length(names(yaxis))==length(yaxis)) yaxisLabel <- names(yaxis)
yaxis <- TRUE
}
if(yaxis && scoreMax>1 && !type %in% c("pie", "pie.stack")){
if(side=="top"){
grid.yaxis(at=yaxisat,
label=yaxisLabel,
main = main,
gp=yaxis.gp,
vp=viewport(x=.5+ifelse(main, -1, 1) *LINEW,
y=feature.height+5.25*GAP*cex+
scoreMax*LINEW*ratio.yx/2*cex,
width=1,
height=scoreMax*LINEW*ratio.yx*cex,
yscale=c(0, scoreMax0+.5)))
}else{
grid.yaxis(at=yaxisat,
label=yaxisLabel,
main = main,
gp=yaxis.gp,
vp=viewport(x=.5+ifelse(main, -1, 1) *LINEW,
y=1-(feature.height+5.25*GAP*cex+
scoreMax*LINEW*ratio.yx/2*cex),
width=1,
height=scoreMax*LINEW*ratio.yx*cex,
yscale=c(scoreMax0+.5, 0)))
}
}
if(length(SNPs$alpha)==length(SNPs)){
SNPs$alpha[is.na(SNPs$alpha)] <- 0
if(all(is.numeric(SNPs$alpha))){
if(any(SNPs$alpha>1)){## convert to 0-1
SNPs$alpha <- SNPs$alpha/max(SNPs$alpha)
}
}else{ ## not correct format.
SNPs$alpha <- as.numeric(factor(as.character(SNPs$alpha)))
SNPs$alpha <- (SNPs$alpha+max(SNPs$alpha))/max(SNPs$alpha)/2
}
}else{
SNPs$alpha <- NULL
}
if(type=="circle"){
if(length(SNPs$shape)==length(SNPs)){
## shape could only be "circle", "square", "diamond", "triangle_point_up", "triangle_point_down"
if(!all(SNPs$shape %in% c("circle", "square", "diamond", "triangle_point_up", "triangle_point_down"))){
message('shape must be "circle", "square", "diamond", "triangle_point_up", or "triangle_point_down"')
SNPs$shape <- as.numeric(factor(SNPs$shape))
SNPs$shape <- rep(c("circle", "square", "diamond", "triangle_point_up", "triangle_point_down"),
max(SNPs$shape))[SNPs$shape]
}
}else{
SNPs$shape <- NULL
}
}
for(m in 1:length(SNPs)){
this.dat <- SNPs[m]
color <- if(is.list(this.dat$color)) this.dat$color[[1]] else this.dat$color
border <-
if(is.list(this.dat$border)) this.dat$border[[1]] else this.dat$border
fill <- if(is.list(this.dat$fill)) this.dat$fill[[1]] else this.dat$fill
alpha <- if(length(this.dat$alpha)>0) this.dat$alpha[[1]] else 1
lwd <- if(is.list(this.dat$lwd)) this.dat$lwd[[1]] else this.dat$lwd
id <- if(is.character(this.dat$label)) this.dat$label else NA
id.col <- if(length(this.dat$label.col)>0) this.dat$label.col else "black"
shape <- if(length(this.dat$shape)>0) this.dat$shape[[1]] else "circle"
rot <- if(length(this.dat$label.rot)>0) this.dat$label.rot else 15
this.cex <- if(length(this.dat$cex)>0) this.dat$cex[[1]][1] else 1
this.dashline.col <-
if(length(this.dat$dashline.col)>0) this.dat$dashline.col[[1]][1] else dashline.col
if(length(names(this.dat))<1) this.dashline.col <- NA
this.dat.mcols <- mcols(this.dat)
this.dat.mcols <- cleanDataMcols(this.dat.mcols, type)
grid.lollipop(x1=convertX(unit(start(this.dat), "native"), "npc",
valueOnly=TRUE),
y1=baseline,
x2=convertX(unit(ifelse(jitter=="node",
lab.pos[m],
start(this.dat)),
"native"), "npc", valueOnly=TRUE),
y2=feature.height,
y3=4*GAP*cex, y4=2.5*GAP*cex,
radius=LINEW*cex/2,
col=color,
border=border,
percent=this.dat.mcols,
edges=100,
type=type,
ratio.yx=ratio.yx,
pin=pin,
scoreMax=scoreMax * LINEW * cex,
scoreType=scoreType,
id=id, id.col=id.col,
cex=this.cex, lwd=lwd, dashline.col=this.dashline.col,
side=side, rot=rot, alpha=alpha, shape=shape)
}
this.height <- getHeight(SNPs,
ratio.yx, LINEW, GAP, cex, type,
scoreMax=scoreMax,
level="data")
labels.rot <- 90
if(length(names(SNPs))>0){
if(type=="pie.stack"){
## unique lab.pos and SNPs
idx <- !duplicated(names(SNPs))
lab.pos <- lab.pos[idx]
SNPs <- SNPs[idx]
}
labels.x <- lab.pos
labels.text <- names(SNPs)
labels.just <- ifelse(side=="top", "left", "right")
labels.hjust <- NULL
labels.vjust <- NULL
labels.check.overlap <- FALSE
labels.default.units <- "native"
labels.gp <- gpar(cex=cex)
## change the parameter by use definations.
for(label.parameter in c("x", "y", "just", "hjust", "vjust",
"rot", "check.overlap", "default.units",
"gp")){
label.para <- paste0("label.parameter.", label.parameter)
if(label.para %in% colnames(mcols(SNPs))){
assign(paste0("labels.", label.parameter),
mcols(SNPs)[, label.para])
}
}
if(!"cex" %in% names(labels.gp)){
labels.gp <- c(labels.gp, cex=cex)
}
mergeList <- function(.ele){
.n <- unique(unlist(lapply(.ele, names)))
.out <- list()
if(length(.n)>0){
for(.name in .n){
.out[[.name]] <- sapply(.ele, function(.e){
if(.name %in% names(.e)){
.e[[.name]][1]
}else{
NA
}
})
}
}else{
.n <- unique(names(.ele))
for(.name in .n){
.out[[.name]] <- unlist(.ele[names(.ele) %in% .name])
}
}
.out
}
labels.gp <- mergeList(labels.gp)
labels.gp[duplicated(names(labels.gp))] <- NULL
labels.gp <- do.call(gpar, labels.gp)
if(jitter=="label"){
## add guide lines
rased.height <- 4*GAP*cex
guide.height <- 2.5*GAP*cex
for(i in 1:length(SNPs)){
this.dashline.col <-
if(length(SNPs[i]$dashline.col)>0)
SNPs[i]$dashline.col[[1]][1] else
dashline.col
if(length(names(SNPs[i]))<1) this.dashline.col <- NA
grid.lines(x=c(start(SNPs[i]), labels.x[i]),
y=c(this.height+feature.height-cex*LINEW,
this.height+feature.height+rased.height),
default.units = labels.default.units,
gp=gpar(col=this.dashline.col, lty=3))
grid.lines(x=c(labels.x[i], labels.x[i]),
y=c(this.height+rased.height+feature.height,
this.height+rased.height+
guide.height+feature.height),
default.units = labels.default.units,
gp=gpar(col=this.dashline.col, lty=3))
}
## add this height
this.height <- this.height + rased.height + guide.height
}
grid.text(x=labels.x, y=this.height + feature.height,
label = labels.text,
just = labels.just,
hjust = labels.hjust,
vjust = labels.vjust,
rot=labels.rot,
check.overlap = labels.check.overlap,
default.units = labels.default.units,
gp=labels.gp)
}
}
popViewport()
}
plotLegend <- function(legend, this.height, LINEH){
ypos <- this.height
pch <- 21
if(length(legend)>0){
if(is.list(legend)){
thisLabels <- legend[["labels"]]
if("pch" %in% names(legend)) pch <- legend[["pch"]]
gp <- legend[!names(legend) %in% c("labels", "pch")]
if(is.null(gp$cex)) gp$cex <- 1
class(gp) <- "gpar"
}else{
thisLabels <- names(legend)
gp <- gpar(fill=legend, cex=1)
}
if(length(thisLabels)>0){
ncol <- getColNum(thisLabels, cex=gp$cex)
topblank <- ceiling(length(thisLabels) / ncol) * gp$cex[1]
pushViewport(viewport(x=.5,
y=ypos+(topblank+.2*gp$cex[1])*LINEH/2,
width=1,
height=topblank*LINEH,
just="bottom"))
this.height <- ypos + (topblank+.2*gp$cex[1])*LINEH
grid.legend(label=thisLabels, ncol=ncol,
byrow=TRUE, vgap=unit(.1*gp$cex[1], "lines"),
hgap=unit(.5*gp$cex[1], "lines"),
pch=pch,
gp=gp)
popViewport()
}
}
this.height + LINEH
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.