R/json.R
In pmoulos/metaseqR2-local: An R package for the analysis and result reporting of RNA-Seq data by combining multiple statistical algorithms
Defines functions
.getStatMap
.getColors
.getColorScheme
.getGroupColorScheme
.unquote_js_fun
dereguloToJSON
maStatToJSON
biodistToJSON
rnacompToJSON
scatterToJSON
volcanoToJSON
filteredToJSON
biasPlotToJSON
boxplotToJSON
readNoiseToJSON
bioSaturationToJSON
bioDetectionToJSON
countsBioToJSON
mdsToJSON
mdsToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- out[1]
x <- obj$x
y <- obj$y
xlim <- obj$xlim
ylim <- obj$ylim
samples <- obj$samples
cols <- .getColorScheme()
# Construct series
counter <- 0
series <- vector("list",length(samples))
names(series) <- names(samples)
for (n in names(series)) {
counter <- counter + 1
series[[n]] <- list()
series[[n]]$name=n
series[[n]]$type="scatter"
series[[n]]$color=cols$fill[counter]
series[[n]]$marker <- list(
lineWidth=1,
states=list(
hover=list(
enabled=TRUE,
lineColor=cols$border[counter]
),
select=list(
fillColor=cols$selected[counter],
lineColor=cols$border[counter],
lineWidth=2
)
)
)
m <- match(samples[[n]],names(x))
if (length(m)>0) {
series[[n]]$data <- makeHighchartsPoints(x[m],y[m])
}
}
switch(jl,
highcharts = {
point.format=paste("<strong>Sample name: </strong>{point.name}<br>",
"<strong>Principal coordinate 1: </strong>{point.x}<br>",
"<strong>Principal coordinate 2: </strong>{point.y}",sep="")
json <- list(
chart=list(
type="scatter",
zoomType="xy"
),
title=list(
text=paste("Multidimensional Scaling")
),
xAxis=list(
title=list(
useHTML=TRUE,
text="1<sup>st</sup> Principal Coordinate",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(xlim[1],3),
max=round(xlim[2],3)
),
yAxis=list(
title=list(
useHTML=TRUE,
text="2<sup>nd</sup> Principal Coordinate",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(ylim[1],3),
max=round(ylim[2],3)
),
plotOptions=list(
scatter=list(
allowPointSelect=TRUE,
tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=point.format
)
)
),
series=unname(series)
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else
return(json)
}
countsBioToJSON <- function(obj,by=c("sample","biotype"),jl=c("highcharts"),
out=c("json","list")) {
by <- tolower(by[1])
jl <- tolower(jl[1])
out <- tolower(out[1])
samples <- obj$samples
status <- obj$status
altnames <- obj$altnames
counts <- round(2^obj$user$counts - 1)
#counts[counts==0] <- 0.001
counts <- counts + 1 # Offset for log
#counts <- obj$user$counts
covars <- obj$user$covars
biotypes <- unique(as.character(covars$biotype))
if (!is.null(altnames))
names(altnames) <- rownames(counts)
grouped <- FALSE
if (is.null(samples)) {
if (is.null(colnames(counts)))
samplenames <- paste("Sample",seq_len(ncol(counts)),sep=" ")
else
samplenames <- colnames(counts)
samples <- list(Samples=samplenames)
}
else if (is.list(samples)) {
samplenames <- unlist(samples,use.names=FALSE)
grouped <- TRUE
}
# y label formatter for logarithmic axis
y.label.formatter <- paste('function() {if(this.value === 0.001)',
'{return 0;} else {return Highcharts.Axis.prototype.',
'defaultLabelFormatter.call(this);}}',sep="")
tooltip.point.formatter <- paste("function() {",
" var min = this.low === 0.001 ? 0 : this.low;" ,
" var q1 = this.q1 === 0.001 ? 0 : this.q1;" ,
" var med = this.median === 0.001 ? 0 : this.median;",
" var q3 = this.q3 === 0.001 ? 0 : this.q3;",
" var max = this.high === 0.001 ? 0 : this.high;",
" var str = 'Maximum: ' + max + '<br/>' +",
" 'Upper quartile: ' + q3 + '<br/>' +",
" 'Median: ' + med + '<br/>' +",
" 'Lower quartile: ' + q1 + '<br/>' +",
" 'Minimum: ' + min + '<br/>';",
" return str;",
"}",sep="")
# Legend clicker
boxplot.onclick <- paste("function() { ",
" var chart = this.chart;",
" var outlier_id = chart.get(this.name);",
" if (!outlier_id.visible) {",
" outlier_id.show();",
" } else {",
" outlier_id.hide();",
" }",
"}",sep="")
# Outliers tooltip
if (is.null(obj$altnames)) {
outlier.pointformat <- paste(
'<strong>Sample {point.category}</strong><br/>',
'Gene ID: {point.name}<br/>',
'Value: {point.y}<br/>',sep=""
)
}
else {
outlier.pointformat <- paste(
'<strong>Sample {point.category}</strong><br/>',
'Gene ID: {point.name}<br/>',
'Gene name: {point.alt_name}<br/>',
'Value: {point.y}<br/>',
sep=""
)
}
if (by=="sample") {
cols <- .getColorScheme(length(biotypes))
boxList <- json <- vector("list",length(samplenames))
names(boxList) <- names(json) <- samplenames
for (n in samplenames) {
boxList[[n]] <- vector("list",length(biotypes))
names(boxList[[n]]) <- biotypes
for (b in biotypes)
boxList[[n]][[b]] <- counts[covars$biotype==b,n]
B <- boxplot(boxList[[n]],plot=FALSE)$stats
colnames(B) <- biotypes
oList <- lapply(names(boxList[[n]]),function(x,M,b) {
v <- b[,x]
o <- which(M[[x]]<v[1] | M[[x]]>v[5])
if (length(o)>0)
return(M[[x]][o])
else
return(NULL)
},boxList[[n]],B)
names(oList) <- biotypes
# Data series
BB <- matrix(0,nrow(B),ncol(B)) # Workaround of strange problem...
colnames(BB) <- colnames(B)
for (jj in seq_len(ncol(B)))
BB[,jj] <- round(B[,jj],3)
d <- as.data.frame(BB)
ids <- 0:(ncol(d)-1)
d <- rbind(ids,d)
names(ids) <- colnames(d)
counter <- 0
series <- vector("list",length(biotypes))
names(series) <- biotypes
for (s in names(series)) {
counter <- counter + 1
series[[s]] <- list()
series[[s]]$name <- s
series[[s]]$color <- cols$fill[counter]
series[[s]]$data <- list(unname(as.list(d[,s])))
r <- round(d[,s])
series[[s]]$tooltip=list(
pointFormat=paste('<strong>Population: ',
length(boxList[[n]][[s]]),'</strong><br/>',
'Maximum: ',r[6],'<br/>',
'Upper quartile: ',r[5],'<br/>',
'Median: ',r[4],'<br/>',
'Lower quartile: ',r[3],'<br/>',
'Minimum: ',r[2],'<br/>',sep="")
)
}
# Outlier series (if any)
counter <- 0
outliers <- vector("list",length(biotypes))
names(outliers) <- biotypes
for (o in names(outliers)) {
counter <- counter + 1
outliers[[o]] <- list()
outliers[[o]]$id <- o
outliers[[o]]$name <- o
outliers[[o]]$type <- "scatter"
outliers[[o]]$showInLegend <- FALSE
outliers[[o]]$color <- cols$fill[counter]
outliers[[o]]$marker <- list(
fillColor=cols$fill[counter],
symbol="circle",
lineWidth=1,
lineColor=cols$border[counter]
)
outliers[[o]]$data <- list()
x <- rep(d[1,o],length(oList[[o]]))
names(x) <- names(oList[[o]])
if (is.null(obj$altnames)) {
outliers[[o]]$data <-
makeHighchartsPoints(x,oList[[o]])
}
else {
outliers[[o]]$data <-
makeHighchartsPoints(x,oList[[o]],
unname(altnames[names(x)]))
}
}
json[[n]] <- switch(jl,
highcharts = {
list(
chart=list(
type="boxplot"
),
title=list(
text=paste("Biotype detection for sample ",n,
sep="")
),
legend=list(
enabled=TRUE,
itemHoverStyle=list(
color="#B40000"
)
),
xAxis=list(
categories=biotypes,
title=list(
text="Biotype",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
)
),
yAxis=list(
type="logarithmic",
showFirstLabel=FALSE,
min=1e-4,
tickInterval=1,
title=list(
useHTML=TRUE,
#text="Read count (log<sub>2</sub>)",
text="Expression (read count)",
margin=25,
style=list(
color="#000000",
fontSize="1.1em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
),
formatter=y.label.formatter
)
),
plotOptions=list(
boxplot=list(
fillColor="#F0F0E0",
lineWidth=2,
medianColor="#000000",
medianWidth=3,
stemColor="#000000",
stemDashStyle="dash",
stemWidth=1,
whiskerColor="#000000",
whiskerLength="75%",
whiskerWidth=1,
grouping=FALSE,
turboThreshold=10000,
tooltip=list(
headerFormat=paste(
'<span style="font-size:1.1em;',
'color:{series.color};',
'font-weight:bold">',
'\u25CF </span>',
'<span style="font-size:1.1em;',
'font-weight:bold">',
'Biotype {series.name}</span><br/>',
sep=""
)
),
events=list(
legendItemClick=boxplot.onclick
)
),
scatter=list(
allowPointSelect=TRUE,
turboThreshold=10000,
tooltip=list(
headerFormat=paste(
'<span style="font-weight:bold;',
'color:{series.color};">',
'\u25CF </span>',
'<span style="font-weight:bold">',
'Biotype {series.name}</span><br/>',
sep=""
),
pointFormat=outlier.pointformat
),
states=list(
hover=list(
marker=list(
enabled=FALSE
)
)
)
)
),
series=c(unname(series),unname(outliers))
)
}
)
}
if (out=="json") {
for (i in seq_along(json))
#json[[i]] <- .unquote_js_fun(toJSON(json[[i]],
# auto_unbox=TRUE,null="null"))
json[[i]] <- toJSON(json[[i]],auto_unbox=TRUE,null="null")
return(json)
}
else
return(json)
}
else if (by=="biotype") {
cols <- .getColorScheme(length(samples))
boxList <- json <- vector("list",length(biotypes))
names(boxList) <- names(json) <- biotypes
for (b in biotypes) {
boxList[[b]] <- vector("list",length(samplenames))
names(boxList[[b]]) <- samplenames
for (n in samplenames)
boxList[[b]][[n]] <- counts[covars$biotype==b,n]
B <- boxplot(boxList[[b]],plot=FALSE)$stats
colnames(B) <- samplenames
oList <- lapply(names(boxList[[b]]),function(x,M,b) {
v <- b[,x]
o <- which(M[[x]]<v[1] | M[[x]]>v[5])
if (length(o)>0)
return(M[[x]][o])
else
return(NULL)
},boxList[[b]],B)
names(oList) <- samplenames
# Data series
BB <- matrix(0,nrow(B),ncol(B)) # Workaround of strange problem...
colnames(BB) <- colnames(B)
for (jj in seq_len(ncol(B)))
BB[,jj] <- round(B[,jj],3)
d <- as.data.frame(BB)
ids <- 0:(ncol(d)-1)
d <- rbind(ids,d)
names(ids) <- colnames(d)
counter <- 0
series <- vector("list",length(samples))
names(series) <- names(samples)
for (s in names(series)) {
counter <- counter + 1
series[[s]] <- list()
series[[s]]$name=s
if (grouped)
series[[s]]$color=cols$fill[counter]
else
series[[s]]$color=cols$fill[1]
m <- match(samples[[s]],colnames(d))
if (length(m) > 1)
series[[s]]$data <- unname(as.list(d[,m]))
else
series[[s]]$data <- list(unname(as.list(d[,m])))
}
# Outlier series (if any)
counter <- 0
outliers <- vector("list",length(samples))
names(outliers) <- names(samples)
for (o in names(outliers)) {
counter <- counter + 1
outliers[[o]] <- list()
outliers[[o]]$id <- o
outliers[[o]]$name <- o
outliers[[o]]$type <- "scatter"
outliers[[o]]$showInLegend <- FALSE
if (grouped) {
outliers[[o]]$color <- cols$fill[counter]
outliers[[o]]$marker <- list(
fillColor=cols$fill[counter],
symbol="circle",
lineWidth=1,
lineColor=cols$border[counter]
)
}
else {
outliers[[o]]$color <- cols$fill[1]
outliers[[o]]$marker <- list(
fillColor=cols$fill[1],
symbol="circle",
lineWidth=1,
lineColor=cols$border[1]
)
}
outliers[[o]]$data <- list()
m <- match(samples[[o]],colnames(d))
if (length(m)>0) {
for (i in m) {
x <- rep(d[1,i],length(oList[[i]]))
names(x) <- names(oList[[i]])
if (is.null(obj$altnames)) {
outliers[[o]]$data <-
makeHighchartsPoints(x,oList[[i]])
}
else {
outliers[[o]]$data <- c(outliers[[o]]$data,
makeHighchartsPoints(x,oList[[i]],
unname(altnames)))
}
}
}
}
json[[b]] <- switch(jl,
highcharts = {
list(
chart=list(
type="boxplot"
),
title=list(
text=paste("Detection for biotype ",b,
" (population: ",lengths(boxList[[b]])[1],
")",sep="")
),
legend=list(
enabled=TRUE
),
xAxis=list(
categories=samplenames,
title=list(
text="Sample name",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
)
),
yAxis=list(
type="logarithmic",
showFirstLabel=FALSE,
min=1e-4,
tickInterval=1,
title=list(
text="Expression (read count)",
margin=25,
style=list(
color="#000000",
fontSize="1.1em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
),
formatter=y.label.formatter
)
),
plotOptions=list(
boxplot=list(
fillColor="#F0F0E0",
lineWidth=2,
medianColor="#000000",
medianWidth=3,
stemColor="#000000",
stemDashStyle="dash",
stemWidth=1,
whiskerColor="#000000",
whiskerLength="75%",
whiskerWidth=1,
grouping=FALSE,
turboThreshold=10000,
tooltip=list(
headerFormat=paste(
'<span style="font-size:1.1em;',
'color:{series.color};',
'font-weight:bold">',
'\u25CF </span>',
'<span style="font-size:1.1em;',
'font-weight:bold">',
'Condition {series.name}</span>',
'<br/>',
'<span style="font-weight:bold;">',
'Sample {point.key}',
'</span><br/>',sep=""
),
pointFormatter=tooltip.point.formatter
),
events=list(
legendItemClick=boxplot.onclick
)
),
scatter=list(
allowPointSelect=TRUE,
turboThreshold=10000,
tooltip=list(
headerFormat=paste(
'<span style="font-weight:bold;',
'color:{series.color};">',
'\u25CF </span>',
'<span style="font-weight:bold">',
'Condition {series.name}</span>',
'<br/>',sep=""
),
pointFormat=outlier.pointformat
),
states=list(
hover=list(
marker=list(
enabled=FALSE
)
)
)
)
),
series=c(unname(series),unname(outliers))
)
}
)
}
if (out=="json") {
for (i in seq_along(json))
#json[[i]] <- .unquote_js_fun(toJSON(json[[i]],
# auto_unbox=TRUE,null="null"))
json[[i]] <- toJSON(json[[i]],auto_unbox=TRUE,null="null")
return(json)
}
else
return(json)
}
}
bioDetectionToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- tolower(out[1])
samples <- obj$samples
status <- obj$status
plotdata <- obj$user$plotdata
covars <- obj$user$covars
if (!is.null(samples) && is.list(samples)) {
samplenames <- unlist(samples,use.names=FALSE)
names(plotdata$biotables) <- samplenames
}
# Otherwise we are using the names present in the input object
abu <- which(plotdata$genome>7)
nabu <- which(plotdata$genome<=7)
cols <- .getColorScheme()
json <- vector("list",length(samplenames))
names(json) <- samplenames
for (n in samplenames) {
# Data series
seriesAbu <- vector("list",3)
names(seriesAbu) <- c("genome","detectionVSgenome","detectionVSsample")
seriesAbu$genome <- list()
seriesAbu$genome$id <- "abu_genome"
seriesAbu$genome$name <- "% in genome"
seriesAbu$genome$color <- cols$trans[1]
seriesAbu$genome$pointPlacement <- -0.2
seriesAbu$genome$data <- round(as.numeric(plotdata$genome[abu]),3)
seriesAbu$detectionVSgenome <- list()
seriesAbu$detectionVSgenome$id <- "abu_detected"
seriesAbu$detectionVSgenome$name <- "% detected"
seriesAbu$detectionVSgenome$color <- cols$trans[2]
seriesAbu$detectionVSgenome$pointPlacement <- 0
seriesAbu$detectionVSgenome$data <- round(as.numeric(
plotdata$biotables[[n]][1,abu]),3)
seriesAbu$detectionVSsample <- list()
seriesAbu$detectionVSsample$id <- "abu_sample"
seriesAbu$detectionVSsample$name <- "% in sample"
seriesAbu$detectionVSsample$color <- cols$trans[3]
seriesAbu$detectionVSsample$pointPlacement <- 0.2
seriesAbu$detectionVSsample$data <- round(as.numeric(
plotdata$biotables[[n]][2,abu]),3)
seriesNabu <- vector("list",3)
names(seriesNabu) <- c("genome","detectionVSgenome",
"detectionVSsample")
seriesNabu$genome <- list()
seriesNabu$genome$name <- "% in genome"
seriesNabu$genome$yAxis <- 1
seriesNabu$genome$pointStart <- length(abu)
seriesNabu$genome$linkedTo <- "abu_genome"
seriesNabu$genome$color <- cols$trans[1]
seriesNabu$genome$pointPlacement <- -0.2
seriesNabu$genome$data <- round(as.numeric(plotdata$genome[nabu]),3)
seriesNabu$detectionVSgenome <- list()
seriesNabu$detectionVSgenome$name <- "% detected"
seriesNabu$detectionVSgenome$yAxis <- 1
seriesNabu$detectionVSgenome$pointStart <- length(abu)
seriesNabu$detectionVSgenome$linkedTo <- "abu_detected"
seriesNabu$detectionVSgenome$color <- cols$trans[2]
seriesNabu$detectionVSgenome$pointPlacement <- 0
seriesNabu$detectionVSgenome$data <- round(as.numeric(
plotdata$biotables[[n]][1,nabu]),3)
seriesNabu$detectionVSsample <- list()
seriesNabu$detectionVSsample$name <- "% in sample"
seriesNabu$detectionVSsample$yAxis <- 1
seriesNabu$detectionVSsample$pointStart <- length(abu)
seriesNabu$detectionVSsample$linkedTo <- "abu_sample"
seriesNabu$detectionVSsample$color <- cols$trans[3]
seriesNabu$detectionVSsample$pointPlacement <- 0.2
seriesNabu$detectionVSsample$data <- round(as.numeric(
plotdata$biotables[[n]][2,nabu]),3)
json[[n]] <- switch(jl,
highcharts = {
list(
chart=list(
type="column",
alignTicks=FALSE
),
title=list(
text=paste("Comparative biotype detection for ",
"sample ",n,sep="")
),
legend=list(
enabled=TRUE,
itemHoverStyle=list(
color="#B40000"
)
),
tooltip=list(
shared=TRUE
),
xAxis=list(
categories=names(plotdata$genome)[c(abu,nabu)],
title=list(
text="Biotype",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
),
plotLines=list(
list(
color="#8A8A8A",
width=1.5,
dashStyle="Dash",
value=length(abu)-0.5
)
),
plotBands=list(
list(
color="#FFFFE0",
from=-0.5,
to=length(abu)-0.5
),
list(
color="#FFECEB",
from=length(abu)-0.5,
to=length(plotdata$genome)
)
)
),
yAxis=list(
list(
min=0,
max=70,
title=list(
text="% of abundant features",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
)
),
list(
min=0,
max=7,
title=list(
text="% of non-abundant features",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
opposite=TRUE
)
),
plotOptions=list(
column=list(
grouping=FALSE,
shadow=FALSE,
groupPadding=0.3,
pointPadding=0.25,
tooltip=list(
headerFormat=paste(
'<span style="font-size:1.1em;',
'font-weight:bold">',
'{point.key}</span><br/>',sep=""
)
)
)
),
series=c(unname(seriesAbu),unname(seriesNabu))
)
}
)
}
if (out=="json") {
for (i in seq_along(json))
json[[i]] <- toJSON(json[[i]],auto_unbox=TRUE,null="null")
return(json)
}
else if (out=="list")
return(json)
}
bioSaturationToJSON <- function(obj,by=c("sample","biotype"),
jl=c("highcharts"),out=c("json","list")) {
by <- tolower(by[1])
jl <- tolower(jl[1])
out <- tolower(out[1])
samples <- obj$samples
plotdata <- obj$user$plotdata
if (!is.null(samples)&& is.list(samples)) {
samplenames <- unlist(samples,use.names=FALSE)
names(plotdata) <- samplenames
}
if (by=="sample") {
json <- vector("list",length(samplenames))
names(json) <- samplenames
for (n in samplenames) {
depth <- round(plotdata[[n]][,1]/1e+6)
global <- round(plotdata[[n]][,2])
M <- plotdata[[n]][,3:ncol(plotdata[[n]]),drop=FALSE]
# To determine the separation
ord <- sort(M[nrow(M),],decreasing=TRUE,index.return=TRUE)
abu <- ord$ix[c(1,2)]
names(abu) <- names(ord$x[c(1,2)])
nabu <- ord$ix[3:length(ord$ix)]
names(nabu) <- names(ord$x[3:length(ord$x)])
cols <- .getColorScheme(ncol(plotdata[[n]])-1)
counter <- 1
global.series <- list(
global=list(
id="global",
name="global",
color=cols$fill[counter],
data=makeHighchartsPoints(depth,global)
)
)
abuSeries <- vector("list",2)
names(abuSeries) <- names(abu)
for (s in names(abuSeries)) {
counter <- counter + 1
abuSeries[[s]] <- list()
abuSeries[[s]]$id <- s
abuSeries[[s]]$name <- s
abuSeries[[s]]$color <- cols$fill[counter]
abuSeries[[s]]$data <- makeHighchartsPoints(depth,
round(M[,s]))
}
nabuSeries <- vector("list",length(3:ncol(M)))
names(nabuSeries) <- names(nabu)
for (s in names(nabuSeries)) {
counter <- counter + 1
nabuSeries[[s]] <- list()
nabuSeries[[s]]$id <- s
nabuSeries[[s]]$name <- s
nabuSeries[[s]]$color <- cols$fill[counter]
nabuSeries[[s]]$data <- makeHighchartsPoints(depth,
round(M[,s]))
}
json[[n]] <- switch(jl,
highcharts = {
list(
chart=list(
type="scatter",
zoomType="xy"
),
title=list(
text=paste("Biotype saturations for sample ",n,
sep="")
),
legend=list(
enabled=TRUE,
itemHoverStyle=list(
color="#B40000"
)
),
xAxis=list(
title=list(
text="Read depth (millions of reads)",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
)
),
yAxis=list(
min=0,
max=max(global),
title=list(
text="Detected features",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
)
),
plotOptions=list(
series=list(
lineWidth=2
),
scatter=list(
tooltip=list(
headerFormat=paste(
'<span style="font-weight:bold;',
'color:{series.color};">',
'\u25CF </span>',
'<span style="font-weight:bold">',
'Biotype {series.name}</span><br/>',
sep=""
),
pointFormat=paste(
"Depth: {point.x}M<br/>",
"Detected features: {point.y}",
sep="")
)
)
),
series=c(unname(global.series),
unname(abuSeries),unname(nabuSeries))
)
}
)
}
if (out=="json") {
for (i in seq_along(json))
json[[i]] <- toJSON(json[[i]],auto_unbox=TRUE,null="null")
return(json)
}
else if (out=="list")
return(json)
}
else if (by=="biotype") {
biotypes <- colnames(plotdata[[1]])[2:ncol(plotdata[[1]])]
depths <- vector("list",length(plotdata))
names(depths) <- samplenames
for (n in samplenames)
depths[[n]] <- round(plotdata[[n]][,1]/1e+6)
json <- vector("list",length(biotypes))
names(json) <- biotypes
for (b in biotypes) {
series <- vector("list",length(plotdata))
names(series) <- samplenames
cols <- .getColorScheme(length(samplenames))
counter <- 0
for (s in names(series)) {
counter <- counter + 1
series[[s]] <- list()
series[[s]]$id <- s
series[[s]]$name <- s
series[[s]]$color <- cols$fill[counter]
series[[s]]$data <- makeHighchartsPoints(depths[[s]],
round(plotdata[[s]][,b]))
}
json[[b]] <- switch(jl,
highcharts = {
list(
chart=list(
type="scatter",
zoomType="xy"
),
title=list(
text=paste("Sample saturations for biotype ",b,
sep="")
),
legend=list(
enabled=TRUE,
itemHoverStyle=list(
color="#B40000"
)
),
xAxis=list(
title=list(
text="Read depth (millions of reads)",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
)
),
yAxis=list(
title=list(
text="Detected features",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
)
),
plotOptions=list(
series=list(
lineWidth=2
),
scatter=list(
tooltip=list(
headerFormat=paste(
'<span style="font-weight:bold;',
'color:{series.color};">',
'\u25CF </span>',
'<span style="font-weight:bold">',
'Sample {series.name}</span><br/>',
sep=""
),
pointFormat=paste(
"Depth: {point.x}M<br/>",
"Detected features: {point.y}",
sep="")
)
)
),
series=c(unname(series))
)
}
)
}
if (out=="json") {
for (i in seq_along(json))
json[[i]] <- toJSON(json[[i]],auto_unbox=TRUE,null="null")
return(json)
}
else if (out=="list") {
names(json) <- biotypes
return(json)
}
}
}
readNoiseToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- tolower(out[1])
d <- obj$user
samples <- obj$samples
# Too many points for a lot of curves of interactive data
if (nrow(d)>1000) {
ii <- sort(sample(seq_len(nrow(d)),998))
ii <- c(1,ii,nrow(d))
d <- cbind(d[ii,1],d[ii,2:ncol(d)])
}
if (is.null(samples))
samples <- seq_len((ncol(d)-1))
if (is.numeric(samples))
samplenames = colnames(dat)[samples+1]
if (is.list(samples))
samplenames <- unlist(samples)
cols <- .getColorScheme(length(samplenames))
# Construct series
counter <- 0
series <- vector("list",length(samplenames))
names(series) <- samplenames
for (n in names(series)) {
counter <- counter + 1
series[[n]] <- list()
series[[n]]$name=n
series[[n]]$color=cols$fill[counter]
series[[n]]$data <- makeHighchartsPoints(d[,1],d[,n],simple=TRUE)
series[[n]]$tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=NULL
)
}
switch(jl,
highcharts = {
json <- list(
chart=list(
type="line",
zoomType="xy"
),
title=list(
text=paste("RNA-Seq mapped reads noise")
),
xAxis=list(
title=list(
text="% detected features",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=0,
max=100
),
yAxis=list(
title=list(
text="% of total reads",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
tickPositions=seq(0,110,10)
),
plotOptions=list(
line=list(
allowPointSelect=TRUE,
lineWidth=1,
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=NULL
),
turboThreshold=50000
)
),
series=unname(series)
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out=="list")
return(json)
}
boxplotToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- tolower(out[1])
b <- obj$plot
name <- obj$samples
status <- obj$status
altnames <- obj$altnames
oList <- obj$user
grouped <- FALSE
if (is.null(name)) {
if (is.null(colnames(b$stats)))
nams <- paste("Sample",seq_len(ncol(b$stats)),sep=" ")
else
nams <- colnames(b$stats)
name <- list(Samples=nams)
}
else if (length(name)==1 && name=="none") {
nams <- rep("",ncol(b$stats))
name <- list(Samples=nams)
}
else if (is.list(name)) { # Is sampleList
nams <- unlist(name,use.names=FALSE)
grouped <- TRUE
}
cols <- .getColorScheme()
# Data series
d <- as.data.frame(round(b$stat,3))
ids <- 0:(ncol(d)-1)
d <- rbind(ids,d)
colnames(d) <- nams
names(ids) <- colnames(d)
counter <- 0
series <- vector("list",length(name))
names(series) <- names(name)
for (n in names(series)) {
counter <- counter + 1
series[[n]] <- list()
series[[n]]$name=n
if (grouped)
series[[n]]$color=cols$fill[counter]
else
series[[n]]$color=cols$fill[1]
m <- match(name[[n]],colnames(d))
if (length(m) > 1)
series[[n]]$data <- unname(as.list(d[,m]))
else
series[[n]]$data <- list(unname(as.list(d[,m])))
}
# Outlier series (if any)
counter <- 0
outliers <- vector("list",length(name))
names(outliers) <- names(name)
for (n in names(outliers)) {
counter <- counter + 1
outliers[[n]] <- list()
outliers[[n]]$id <- n
outliers[[n]]$name <- n
outliers[[n]]$type <- "scatter"
outliers[[n]]$showInLegend <- FALSE
if (grouped) {
outliers[[n]]$color <- cols$fill[counter]
outliers[[n]]$marker <- list(
fillColor=cols$fill[counter],
symbol="circle",
lineWidth=1,
lineColor=cols$border[counter]
)
}
else {
outliers[[n]]$color <- cols$fill[1]
outliers[[n]]$marker <- list(
fillColor=cols$fill[1],
symbol="circle",
lineWidth=1,
lineColor=cols$border[1]
)
}
outliers[[n]]$data <- list()
m <- match(name[[n]],colnames(d))
if (length(m)>0) {
for (i in m) {
x <- rep(d[1,i],length(oList[[i]]))
names(x) <- names(oList[[i]])
outliers[[n]]$data <- c(outliers[[n]]$data,
makeHighchartsPoints(x,oList[[i]],unname(altnames)))
}
}
}
# Boxplot tooltip point formatter for the case of zeros
tooltip.point.formatter <- paste("function() {",
" var min = this.low === 0.001 ? 0 : this.low;" ,
" var q1 = this.q1 === 0.001 ? 0 : this.q1;" ,
" var med = this.median === 0.001 ? 0 : this.median;",
" var q3 = this.q3 === 0.001 ? 0 : this.q3;",
" var max = this.high === 0.001 ? 0 : this.high;",
" var str = 'Maximum: ' + max + '<br/>' +",
" 'Upper quartile: ' + q3 + '<br/>' +",
" 'Median: ' + med + '<br/>' +",
" 'Lower quartile: ' + q1 + '<br/>' +",
" 'Minimum: ' + min + '<br/>';",
" return str;",
"}",sep="")
# Legend clicker
boxplot.onclick <- paste("function() {",
" var chart = this.chart;",
" var outlier_id = chart.get(this.name);",
" if (!outlier_id.visible) {",
" outlier_id.show();",
" } else {",
" outlier_id.hide();",
" }",
"}",sep="")
if (is.null(obj$altnames)) {
outlier.pointformat=paste(
'<strong>Sample {point.category}</strong><br/>',
'Gene ID: {point.name}<br/>',
'Value: {point.y}<br/>',sep=""
)
}
else {
outlier.pointformat=paste(
'<strong>Sample {point.category}</strong><br/>',
'Gene ID: {point.name}<br/>',
'Gene name: {point.alt_name}<br/>',
'Value: {point.y}<br/>',sep=""
)
}
json <- switch(jl,
highcharts = {
list(
chart=list(
type="boxplot"
),
title=list(
text=paste("Boxplot ",status,sep="")
),
legend=list(
enabled=TRUE
),
xAxis=list(
categories=nams,
title=list(
text="Sample name",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
)
),
yAxis=list(
title=list(
useHTML=TRUE,
text="Read count (log<sub>2</sub>)",
margin=30,
style=list(
color="#000000",
fontSize="1.1em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
)
),
plotOptions=list(
boxplot=list(
fillColor="#F0F0E0",
lineWidth=2,
medianColor="#000000",
medianWidth=3,
stemColor="#000000",
stemDashStyle="dash",
stemWidth=1,
whiskerColor="#000000",
whiskerLength="75%",
whiskerWidth=1,
grouping=FALSE,
tooltip=list(
headerFormat=paste(
'<span style="font-size:1.1em;',
'color:{series.color};',
'font-weight:bold">',
'\u25CF </span>',
'<span style="font-size:1.1em;',
'font-weight:bold">',
'Condition {series.name}</span><br/>',
'<span style="font-weight:bold">',
'Sample {point.key}</span><br/>',sep=""
),
pointFormatter=tooltip.point.formatter
),
events=list(
legendItemClick=boxplot.onclick
)
),
scatter=list(
allowPointSelect=TRUE,
tooltip=list(
headerFormat=paste(
'<span style="font-weight:bold;',
'color:{series.color};">',
'\u25CF </span>',
'<span style="font-weight:bold">',
'Condition {series.name}</span><br/>',
sep=""
),
pointFormat=outlier.pointformat
),
states=list(
hover=list(
marker=list(
enabled=FALSE
)
)
)
)
),
series=c(unname(series),unname(outliers))
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else
return(json)
}
biasPlotToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- tolower(out[1])
counts <- round(nat2log(obj$user$counts),3)
status <- obj$status
covar <- obj$user$covar
covarname <- obj$user$covarname
samples <- obj$samples
# Too many points for a lot of curves of interactive data
if (nrow(counts)>2000) {
#set.seed(seed)
ii <- sample(seq_len(nrow(counts)),2000)
counts <- counts[ii,]
covar <- covar[ii]
}
# If length bias, not nice to have x-axis at -200k
if (covarname == "lengthbias")
minX <- ifelse(max(covar>100),0,"undefined")
else
minX <- 0.1
if (is.null(samples)) {
if (is.null(colnames(x)))
samplenames <- paste("Sample",seq_len(ncol(counts)),sep=" ")
else
samplenames <- colnames(counts)
samples <- list(Samples=samplenames)
cols <- .getColorScheme(length(samples))
}
else if (is.list(samples)) { # Is sampleList
samplenames <- unlist(samples,use.names=FALSE)
grouped <- TRUE
cols <- .getColorScheme(length(samplenames))
}
colnames(counts) <- samplenames
# Construct series
counter <- 0
series <- vector("list",length(samplenames))
names(series) <- samplenames
for (n in names(series)) {
counter <- counter + 1
x <- counts[,n]
fit <- lowess(covar,x)
series[[n]] <- list()
series[[n]]$name <- n
series[[n]]$color <- cols$fill[counter]
series[[n]]$data <- lapply(seq_len(length(x)),function(i,x,y) {
return(c(x[i],y[i])) },round(fit$x,3),round(fit$y,3))
}
switch(jl,
highcharts = {
json <- list(
chart=list(
type="line",
zoomType="xy"
),
title=list(
text=paste(covarname," bias detection - ",status)
),
xAxis=list(
min=minX,
title=list(
text=covarname,
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE
),
yAxis=list(
title=list(
useHTML=TRUE,
text="Read count (log<sub>2</sub>)",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE
),
plotOptions=list(
line=list(
marker=list(
enabled=FALSE,
states=list(
hover=list(
enabled=FALSE
)
)
),
tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=NULL
),
turboThreshold=50000
)
),
series=unname(series)
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out=="list")
return(json)
}
filteredToJSON <- function(obj,by=c("chromosome","biotype"),
jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
by <- tolower(by[1])
out <- tolower(out[1])
filtered <- obj$user$filtered
total <- obj$user$total
cols <- .getColorScheme(2)
if (by=="chromosome") {
chrTab <- table(as.character(filtered$chromosome))
chr <- as.numeric(chrTab)
names(chr) <- names(chrTab)
chrAllTab <- table(as.character(total$chromosome))
chrAll <- as.numeric(chrAllTab)
names(chrAll) <- names(chrAllTab)
barlabChr <- as.character(chr)
perChr <- round(chr/chrAll[names(chr)],3)
perChr[perChr>1] <- 1
series <- vector("list",2)
names(series) <- c("number","fraction")
series$number <- list()
series$number$id <- "chr_number"
series$number$name <- "Number of genes"
series$number$color <- cols$fill[1]
series$number$pointPlacement <- -0.2
series$number$data <- unname(chr)
series$fraction <- list()
series$fraction$id <- "chr_fraction"
series$fraction$name <- "Fraction of total genes"
series$fraction$color <- cols$fill[2]
series$fraction$pointPlacement <- 0.2
series$fraction$yAxis <- 1
series$fraction$data <- unname(perChr)
what <- chr
}
else if (by=="biotype") {
btTab <- table(as.character(filtered$biotype))
bt <- as.numeric(btTab)
names(bt) <- names(btTab)
btAllTab <- table(as.character(total$biotype))
btAll <- as.numeric(table(as.character(total$biotype)))
names(btAll) <- names(btAllTab)
barlabBt <- as.character(bt)
perBt <- round(bt/btAll[names(bt)],3)
perBt[perBt>1] <- 1
series <- vector("list",2)
names(series) <- c("number","fraction")
series$number <- list()
series$number$id <- "bt_number"
series$number$name <- "Number of genes"
series$number$color <- cols$fill[1]
series$number$pointPlacement <- -0.2
series$number$data <- unname(bt)
series$fraction <- list()
series$fraction$id <- "bt_fraction"
series$fraction$name <- "Fraction of total genes"
series$fraction$color <- cols$fill[2]
series$fraction$pointPlacement <- 0.2
series$fraction$yAxis <- 1
series$fraction$data <- unname(perBt)
what <- bt
}
json <- switch(jl,
highcharts = {
list(
chart=list(
type="column",
alignTicks=FALSE
),
title=list(
text=paste("Filtered genes per ",by,sep="")
),
legend=list(
enabled=TRUE,
itemHoverStyle=list(
color="#B40000"
)
),
tooltip=list(
shared=TRUE
),
xAxis=list(
categories=names(what),
title=list(
text=paste(toupper(substr(by,1,1)),substr(by,2,
nchar(by)),sep=""),
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
)
),
yAxis=list(
list(
lineColor=cols$fill[1],
lineWidth=2,
min=0,
tickAmount=11,
title=list(
text="Number of genes",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
offset=10
),
list(
lineColor=cols$fill[2],
lineWidth=2,
min=0,
max=1,
tickAmount=11,
#tickInterval=0.1,
title=list(
text="Fraction of total genes",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
opposite=TRUE,
offset=10
)
),
plotOptions=list(
column=list(
grouping=FALSE,
shadow=FALSE,
groupPadding=0.2,
pointPadding=0.2,
tooltip=list(
headerFormat=paste(
'<span style="font-size:1.1em;',
'font-weight:bold">',
'{point.key}</span><br/>',sep=""
)
)
)
),
series=c(unname(series))
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out=="list")
return(json)
}
volcanoToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- tolower(out[1])
f <- obj$x
p <- obj$y
xlim <- obj$xlim
ylim <- obj$ylim
altNames <- obj$altnames
pcut <- obj$pcut
fcut <- obj$fcut
up <- obj$user$up
down <- obj$user$down
ff <- obj$user$unf
pp <- obj$user$unp
altNamesNeutrall <- obj$user$ualt
con <- obj$user$con
switch(jl,
highcharts = {
if (is.null(altNames))
point.format=paste("<strong>Gene ID: </strong>{point.name}<br>",
"<strong>Fold change: </strong>{point.x}<br>",
"<strong>Significance: </strong>{point.y}",sep="")
else
point.format=paste("<strong>Gene name: </strong>",
"{point.alt_name}<br>",
"<strong>Gene ID: </strong>{point.name}<br>",
"<strong>Fold change: </strong>{point.x}<br>",
"<strong>Significance: </strong>{point.y}",sep="")
json <- list(
chart=list(
type="scatter",
zoomType="xy"
),
title=list(
text=paste("Volcano plot for",con)
),
xAxis=list(
title=list(
text="Fold change",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(xlim[1],3),
max=round(xlim[2],3)
),
yAxis=list(
title=list(
useHTML=TRUE,
text="Significance (-log<sub>10</sub>(p-value))",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(ylim[1]-2,3),
max=round(ylim[2],3)
),
#legend=list(
# layout="vertical",
# align="left",
# verticalAlign="top",
# floating=TRUE,
# backgroundColor="#FFFFFF",
# borderWidth=1
#),
plotOptions=list(
scatter=list(
allowPointSelect=TRUE,
marker=list(
radius=2,
states=list(
hover=list(
enabled=TRUE,
lineColor="#333333"
)
)
),
states=list(
hover=list(
marker=list(
enabled=FALSE
)
)
),
tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=point.format
),
turboThreshold=50000
)
),
series=list(
list(
name="Up-regulated",
color="#EE0000",
marker=list(
symbol="circle"
),
data=makeHighchartsPoints(f[up],-log10(p[up]),
unname(altNames[up]))
),
list(
name="Down-regulated",
marker=list(
symbol="circle"
),
color="#00CD00",
data=makeHighchartsPoints(f[down],-log10(p[down]),
unname(altNames[down]))
),
list(
name="Unregulated",
marker=list(
symbol="circle"
),
color="#0000EE",
data=makeHighchartsPoints(ff,-log10(pp),
unname(altNamesNeutrall))
),
list(
name="Downfold threshold",
color="#000000",
type="line",
dashStyle="dash",
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste('<strong>{series.name}',
'</strong><br/>',sep=""),
pointFormat=paste('<strong>Threshold: ',
'</strong>{point.x}<br/>',sep="")
),
data=list(round(c(-fcut,ylim[1]-5),3),
round(c(-fcut,ylim[2]),3))
),
list(
name="Upfold threshold",
color="#000000",
type="line",
dashStyle="Dash",
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste('<strong>{series.name}',
'</strong><br/>',sep=""),
pointFormat=paste('<strong>Threshold: ',
'</strong>{point.x}<br/>',sep="")
),
data=list(round(c(fcut,ylim[1]-5),3),
round(c(fcut,ylim[2]),3))
),
list(
name="Significance threshold",
color="#000000",
type="line",
dashStyle="DashDot",
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste('<strong>{series.name}',
'</strong><br/>',sep=""),
pointFormat=paste('<strong>Threshold: ',
'</strong>{point.y}<br/>',sep="")
),
data=list(round(c(xlim[1],-log10(pcut)),3),
round(c(xlim[2],-log10(pcut)),3))
)
)
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out=="list")
return(json)
}
scatterToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- tolower(out[1])
x <- obj$x
y <- obj$y
altNames <- obj$altnames
type <- obj$user$covarname
status <- obj$status
samples <- obj$samples
if (type=="Mean-Difference") {
xLab <- "Mean"
yLab <- "Difference"
}
else if (type=="Mean-Variance") {
xLab <- "Mean"
yLab <- "Variance"
}
else if (type=="X-Y") {
xLab <- paste("Expression for",samples[1])
yLab <- paste("Expression for",samples[2])
}
# Too many points for mostly static, QC plots
if (length(x)>10000) {
ii <- sample(seq_len(length(x)),10000)
x <- x[ii]
y <- y[ii]
}
fit <- lowess(x,y)
stMsg <- ""
if (!is.null(status))
stMsg <- status
switch(jl,
highcharts = {
#if (is.null(altNames))
# point.format=paste("<strong>Gene ID: </strong>{point.name}<br>",
# "<strong>",xLab,": </strong>{point.x}<br>",
# "<strong>",yLab,": </strong>{point.y}",sep="")
#else
# point.format=paste("<strong>Gene name: </strong>",
# "{point.alt_name}<br>",
# "<strong>Gene ID: </strong>{point.name}<br>",
# "<strong>",xLab,": </strong>{point.x}<br>",
# "<strong>",yLab,": </strong>{point.y}",sep="")
point.format=paste("<strong>",xLab,": </strong>{point.x}<br>",
"<strong>",yLab,": </strong>{point.y}",sep="")
json <- list(
chart=list(
type="scatter",
zoomType="xy"
),
title=list(
text=paste(type,"plot for",stMsg,"samples",samples[1],
"and",samples[2])
),
xAxis=list(
title=list(
text=xLab,
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(min(x),3),
max=round(max(x),3)
),
yAxis=list(
title=list(
useHTML=TRUE,
text=yLab,
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(min(y),3),
max=round(max(y),3)
),
plotOptions=list(
scatter=list(
turboThreshold=25000
),
line=list(
turboThreshold=25000
)
),
series=list(
list(
type="scatter",
name="Genes/Transcripts",
#color="#00ABEE",
color="rgba(0,171,238,0.5)",
marker=list(
radius=0.5
),
#data=makeHighchartsPoints(x,y,unname(altNames)),
data=makeHighchartsPoints(x,y,simple=TRUE),
tooltip=list(
followPointer=FALSE,
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=point.format
)
),
list(
type="line",
name="Trend",
marker=list(
enabled=FALSE
),
color="#E40000",
data=lapply(seq_len(length(x)),function(i,x,y) {
return(c(x[i],y[i]))
},round(fit$x,3),round(fit$y,3))
)
)
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out=="list")
return(json)
}
rnacompToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- tolower(out[1])
status <- obj$status
dat <- obj$user$plotdata$data2plot
samples <- obj$samples
refColumn <- obj$user$plotdata$refColumn
# Too many points for a lot of curves of interactive data
if (nrow(dat)>1000) {
ii <- sort(sample(seq_len(nrow(dat)),998))
ii <- c(1,ii,nrow(dat))
dat <- cbind(dat[ii,1],dat[ii,2:ncol(dat)])
}
if (is.list(samples))
samplenames <- unlist(samples)
samplenames <- setdiff(samplenames,refColumn)
dat <- as.matrix(dat[,samplenames])
datDens <- apply(dat,2,density,adjust=1.5)
limY <- c(0,max(vapply(datDens,function (x) max(x$y,na.rm=TRUE),
numeric(1))))
cols <- .getColorScheme(length(samplenames))
# Construct series
counter <- 0
densSeries <- vector("list",length(samplenames))
names(densSeries) <- samplenames
for (n in names(densSeries)) {
counter <- counter + 1
densSeries[[n]] <- list()
densSeries[[n]]$name=n
densSeries[[n]]$color=cols$fill[counter]
densSeries[[n]]$data <-
makeHighchartsPoints(datDens[[n]]$x,datDens[[n]]$y)
densSeries[[n]]$tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=NULL
)
}
counter <- 0
abSeries <- vector("list",length(samplenames))
names(abSeries) <- samplenames
for (n in names(abSeries)) {
counter <- counter + 1
abSeries[[n]] <- list()
abSeries[[n]]$name=paste(n,"median")
abSeries[[n]]$color=cols$fill[counter]
abSeries[[n]]$data <-
makeHighchartsPoints(rep(median(dat[,n],na.rm=TRUE),nrow(dat)),
seq(limY[1],limY[2],length.out=nrow(dat)))
abSeries[[n]]$enableMouseTracking=FALSE
abSeries[[n]]$dashStyle="Dash"
}
switch(jl,
highcharts = {
json <- list(
chart=list(
type="line",
zoomType="xy"
),
title=list(
text=paste("RNA-composition for",status,"mapped reads")
),
xAxis=list(
title=list(
text="log<sub>2</sub>(sample/reference sample)",
margin=20,
useHTML=TRUE,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1
),
yAxis=list(
title=list(
text="Density",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=limY[1],
max=limY[2]
),
plotOptions=list(
line=list(
allowPointSelect=TRUE,
lineWidth=1,
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=NULL
),
turboThreshold=50000
)
),
series=c(unname(densSeries),unname(abSeries))
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out=="list")
return(json)
}
biodistToJSON <- function(obj,jl=c("highcharts"),by=c("chromosome","biotype"),
out=c("json","list")) {
jl <- tolower(jl[1])
by <- by[1]
out <- tolower(out[1])
plotdataChromosome <- obj$user$plotdata$chromosome
plotdataBiotype <- obj$user$plotdata$biotype
cols <- .getColorScheme()
if (by == "chromosome") {
# Data series
series <- vector("list",3)
names(series) <- c("genome","chromosome_deg","deg_chromosome")
series$genome <- list()
series$genome$id <- "genome"
series$genome$name <- "% chromosome in genome"
series$genome$color <- cols$trans[1]
series$genome$pointPlacement <- -0.2
series$genome$data <- round(as.numeric(plotdataChromosome[1,]),3)
series$chromosome_deg <- list()
series$chromosome_deg$id <- "chromosome_deg"
series$chromosome_deg$name <- "% chromosome in DEG"
series$chromosome_deg$color <- cols$trans[2]
series$chromosome_deg$pointPlacement <- 0
series$chromosome_deg$data <-
round(as.numeric(plotdataChromosome[2,]),3)
series$deg_chromosome <- list()
series$deg_chromosome$id <- "deg_chromosome"
series$deg_chromosome$name <- "% DEG in chromosome"
series$deg_chromosome$color <- cols$trans[3]
series$deg_chromosome$pointPlacement <- 0.2
series$deg_chromosome$data <-
round(as.numeric(plotdataChromosome[3,]),3)
json <- switch(jl,
highcharts = {
list(
chart=list(
type="column",
alignTicks=FALSE
),
title=list(
text="DEG distribution across chromosomes"
),
legend=list(
enabled=TRUE,
itemHoverStyle=list(
color="#B40000"
)
),
tooltip=list(
shared=TRUE
),
xAxis=list(
categories=names(plotdataChromosome),
title=list(
text="Chromosome",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
)
),
yAxis=list(
list(
min=0,
max=ceiling(max(plotdataChromosome[1,])),
title=list(
text="% of features",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
)
)
),
plotOptions=list(
column=list(
grouping=FALSE,
shadow=FALSE,
groupPadding=0.3,
pointPadding=0.25,
tooltip=list(
headerFormat=paste(
'<span style="font-size:1.1em;',
'font-weight:bold">',
'{point.key}</span><br/>',sep=""
)
)
)
),
series=unname(series)
)
}
)
}
if (by == "biotype") {
# For biotype
abu <- which(plotdataBiotype[1,]>7)
nabu <- which(plotdataBiotype[1,]<=7)
# Data series
seriesAbu <- vector("list",3)
names(seriesAbu) <- c("genome","biotype_deg","deg_biotype")
seriesAbu$genome <- list()
seriesAbu$genome$id <- "abu_genome"
seriesAbu$genome$name <- "% biotype in genome"
seriesAbu$genome$color <- cols$trans[1]
seriesAbu$genome$pointPlacement <- -0.2
seriesAbu$genome$data <- round(as.numeric(plotdataBiotype[1,abu]),3)
seriesAbu$biotype_deg <- list()
seriesAbu$biotype_deg$id <- "abu_biotype_deg"
seriesAbu$biotype_deg$name <- "% biotype in DEG"
seriesAbu$biotype_deg$color <- cols$trans[2]
seriesAbu$biotype_deg$pointPlacement <- 0
seriesAbu$biotype_deg$data <-
round(as.numeric(plotdataBiotype[2,abu]),3)
seriesAbu$deg_biotype <- list()
seriesAbu$deg_biotype$id <- "abu_deg_biotype"
seriesAbu$deg_biotype$name <- "% DEG in biotype"
seriesAbu$deg_biotype$color <- cols$trans[3]
seriesAbu$deg_biotype$pointPlacement <- 0.2
seriesAbu$deg_biotype$data <-
round(as.numeric(plotdataBiotype[3,abu]),3)
seriesNabu <- vector("list",3)
names(seriesNabu) <- c("genome","biotype_deg","deg_biotype")
seriesNabu$genome <- list()
seriesNabu$genome$name <- "% biotype in genome"
seriesNabu$genome$yAxis <- 1
seriesNabu$genome$pointStart <- length(abu)
seriesNabu$genome$linkedTo <- "abu_genome"
seriesNabu$genome$color <- cols$trans[1]
seriesNabu$genome$pointPlacement <- -0.2
seriesNabu$genome$data <- round(as.numeric(plotdataBiotype[1,nabu]),3)
seriesNabu$biotype_deg <- list()
seriesNabu$biotype_deg$name <- "% biotype in DEG"
seriesNabu$biotype_deg$yAxis <- 1
seriesNabu$biotype_deg$pointStart <- length(abu)
seriesNabu$biotype_deg$linkedTo <- "abu_detected"
seriesNabu$biotype_deg$color <- cols$trans[2]
seriesNabu$biotype_deg$pointPlacement <- 0
seriesNabu$biotype_deg$data <-
round(as.numeric(plotdataBiotype[2,nabu]),3)
seriesNabu$deg_biotype <- list()
seriesNabu$deg_biotype$name <- "% DEG in biotype"
seriesNabu$deg_biotype$yAxis <- 1
seriesNabu$deg_biotype$pointStart <- length(abu)
seriesNabu$deg_biotype$linkedTo <- "abu_sample"
seriesNabu$deg_biotype$color <- cols$trans[3]
seriesNabu$deg_biotype$pointPlacement <- 0.2
seriesNabu$deg_biotype$data <-
round(as.numeric(plotdataBiotype[3,nabu]),3)
json <- switch(jl,
highcharts = {
list(
chart=list(
type="column",
alignTicks=FALSE
),
title=list(
text="DEG distribution across biotypes"
),
legend=list(
enabled=TRUE,
itemHoverStyle=list(
color="#B40000"
)
),
tooltip=list(
shared=TRUE
),
xAxis=list(
categories=colnames(plotdataBiotype)[c(abu,nabu)],
title=list(
text="Biotype",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
),
plotLines=list(
list(
color="#8A8A8A",
width=1.5,
dashStyle="Dash",
value=length(abu)-0.5
)
),
plotBands=list(
list(
color="#FFFFE0",
from=-0.5,
to=length(abu)-0.5
),
list(
color="#FFECEB",
from=length(abu)-0.5,
to=ncol(plotdataBiotype)
)
)
),
yAxis=list(
list(
min=0,
max=70,
title=list(
text="% of abundant features",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
)
),
list(
min=0,
max=7,
title=list(
text="% of non-abundant features",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
opposite=TRUE
)
),
plotOptions=list(
column=list(
grouping=FALSE,
shadow=FALSE,
groupPadding=0.3,
pointPadding=0.25,
tooltip=list(
headerFormat=paste(
'<span style="font-size:1.1em;',
'font-weight:bold">',
'{point.key}</span><br/>',sep=""
)
)
)
),
series=c(unname(seriesAbu),unname(seriesNabu))
)
}
)
}
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out=="list")
return(json)
}
maStatToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- out[1]
a <- obj$x
f <- obj$y
p <- obj$user$p
xlim <- obj$xlim
ylim <- obj$ylim
pcut <- obj$pcut
fcut <- obj$fcut
altNames <- obj$altnames
con <- obj$user$con
#stat <- obj$user$stat
conlab <- strsplit(con,"_vs_")
conlab <- paste(conlab[[1]][1],"against",conlab[[1]][2])
#conlab <- paste(conlab[[1]][2],"against",conlab[[1]][1])
#statMap <- .getStatMap()
#statlab <- statMap[[stat]]
if (!is.null(p)) {
upstat <- which(f>=fcut & p<pcut)
downstat <- which(f<=-fcut & p<pcut)
up <- which(f>=fcut & p>=pcut)
down <- which(f<=-fcut & p>=pcut)
poor <- which(p<pcut & abs(f)<fcut)
neutral <- setdiff(seq_len(length(a)),
Reduce("union",list(upstat,downstat,up,down,poor)))
}
else {
upstat <- downstat <- poor <- integer(0)
up <- which(f>=fcut)
down <- which(f<=-fcut)
neutral <- setdiff(seq_len(length(a)),union(up,down))
}
switch(jl,
highcharts = {
series <- list()
counter <- 0
if (length(upstat)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significantly up-regulated",
color="#EE0000",
marker=list(
radius=3
),
data=makeHighchartsPoints(
x=a[upstat],
y=f[upstat],
a=unname(altNames[upstat]),
p=if (!is.null(p)) -log10(p[upstat]) else NULL
)
)
}
if (length(downstat)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significantly down-regulated",
color="#00EE00",
marker=list(
radius=3
),
data=makeHighchartsPoints(
x=a[downstat],
y=f[downstat],
a=unname(altNames[downstat]),
p=if (!is.null(p)) -log10(p[downstat]) else NULL
)
)
}
if (length(up)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Up-regulated",
color="#B80000",
marker=list(
radius=2
),
data=makeHighchartsPoints(
x=a[up],
y=f[up],
a=unname(altNames[up]),
p=if (!is.null(p)) -log10(p[up]) else NULL
)
)
}
if (length(down)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Down-regulated",
color="#008000",
marker=list(
radius=2
),
data=makeHighchartsPoints(
x=a[down],
y=f[down],
a=unname(altNames[down]),
p=if (!is.null(p)) -log10(p[down]) else NULL
)
)
}
if (length(poor)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significant only",
color="#FFA600",
data=makeHighchartsPoints(
x=a[poor],
y=f[poor],
a=unname(altNames[poor]),
p=if (!is.null(p)) -log10(p[poor]) else NULL
)
)
}
if (length(neutral)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Neutral",
color="#858585",
data=makeHighchartsPoints(
x=a[neutral],
y=f[neutral],
a=unname(altNames[neutral]),
p=if (!is.null(p)) -log10(p[neutral]) else NULL
)
)
}
if (is.null(altNames))
point.format=paste("<strong>Gene ID: </strong>{point.name}<br>",
"<strong>Average expression: </strong>{point.x}<br>",
"<strong>Fold change: </strong>{point.y}<br>",
"<strong>Significance: </strong>{point.sig}",sep="")
else
point.format=paste("<strong>Gene name: </strong>",
"{point.alt_name}<br>",
"<strong>Gene ID: </strong>{point.name}<br>",
"<strong>Average expression: </strong>{point.x}<br>",
"<strong>Fold change: </strong>{point.y}<br>",
"<strong>Significance: </strong>{point.sig}",sep="")
json <- list(
chart=list(
type="scatter",
zoomType="xy"
),
title=list(
text=paste("Mean-Difference (MA) plot for",conlab)
),
xAxis=list(
title=list(
text="Average expression",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(xlim[1],3),
max=round(xlim[2],3)
),
yAxis=list(
title=list(
useHTML=TRUE,
text="Fold change (log<sub>2</sub>)",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(ylim[1],3),
max=round(ylim[2],3)
),
plotOptions=list(
scatter=list(
allowPointSelect=TRUE,
marker=list(
radius=2,
symbol="circle",
states=list(
hover=list(
enabled=TRUE,
lineColor="#333333"
)
)
),
states=list(
hover=list(
marker=list(
enabled=FALSE
)
)
),
#events=list(
# legendItemClick=paste("function() {",
# "return false; }")
#),
tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=point.format
),
turboThreshold=50000
)
),
series=series
)
}
)
if (out == "json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out == "list")
return(json)
}
dereguloToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- out[1]
xlim <- obj$xlim
ylim <- obj$ylim
pcut <- obj$pcut
fcut <- obj$fcut
altNames <- obj$altnames
fmat <- obj$user$fmat
pmat <- obj$user$pmat
conlabX <- strsplit(colnames(fmat)[1],"_vs_")
conlabX <- paste(conlabX[[1]][1],"against",conlabX[[1]][2])
conlabY <- strsplit(colnames(fmat)[2],"_vs_")
conlabY <- paste(conlabY[[1]][1],"against",conlabY[[1]][2])
# red
upupstat <- which(apply(fmat,1,function(x) all(x >= fcut)) &
apply(pmat,1,function(x) all(x < pcut)))
# green
downdownstat <- which(apply(fmat,1,function(x) all(x <= -fcut)) &
apply(pmat,1,function(x) all(x < pcut)))
# red3
upup <- which(apply(fmat,1,function(x) all(x >= fcut)) &
apply(pmat,1,function(x) any(x >= pcut)))
# green3
downdown <- which(apply(fmat,1,function(x) all(x <= -fcut)) &
apply(pmat,1,function(x) any(x >= pcut)))
# orange
updownstat <- which(apply(fmat,1,
function(x) x[1] >= fcut & x[2] <= -fcut) &
apply(pmat,1,function(x) all(x < pcut)))
# blue
downupstat <- which(apply(fmat,1,
function(x) x[1] <= -fcut & x[2] >= fcut) &
apply(pmat,1,function(x) all(x < pcut)))
# orange3
updown <- which(apply(fmat,1,function(x) x[1] >= fcut & x[2] <= -fcut) &
apply(pmat,1,function(x) any(x >= pcut)))
# blue3
downup <- which(apply(fmat,1,function(x) x[1] <= -fcut & x[2] >= fcut) &
apply(pmat,1,function(x) any(x >= pcut)))
# black
poor <- which(apply(pmat,1,function(x) all(x < pcut)) &
apply(fmat,1,function(x) any(abs(x) < fcut)))
# gray70
nones <- which(apply(pmat,1,function(x) any(x >= pcut)) &
apply(fmat,1,function(x) all(abs(x) < fcut)))
# gray40
neutral <- setdiff(seq_len(nrow(fmat)),
Reduce("union",list(upupstat,downdownstat,upup,downdown,updownstat,
downupstat,updown,downup,poor,nones)))
switch(jl,
highcharts = {
series <- list()
counter <- 0
if (length(upupstat)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significantly both up-regulated",
color="#EE0000",
marker=list(
radius=3
),
data=makeHighchartsPoints(
x=fmat[upupstat,1],
y=fmat[upupstat,2],
a=unname(altNames[upupstat])
)
)
}
if (length(downdownstat)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significantly both down-regulated",
color="#00EE00",
marker=list(
radius=3
),
data=makeHighchartsPoints(
x=fmat[downdownstat,1],
y=fmat[downdownstat,2],
a=unname(altNames[downdownstat])
)
)
}
if (length(upup)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Both up-regulated",
color="#B80000",
marker=list(
radius=2
),
data=makeHighchartsPoints(
x=fmat[upup,1],
y=fmat[upup,2],
a=unname(altNames[upup])
)
)
}
if (length(downdown)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Both down-regulated",
color="#008000",
marker=list(
radius=2
),
data=makeHighchartsPoints(
x=fmat[downdown,1],
y=fmat[downdown,2],
a=unname(altNames[downdown])
)
)
}
if (length(updownstat)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significantly up-down-regulated",
color="#FFB700",
marker=list(
radius=3
),
data=makeHighchartsPoints(
x=fmat[updownstat,1],
y=fmat[updownstat,2],
a=unname(altNames[updownstat])
)
)
}
if (length(downupstat)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significantly down-up-regulated",
color="#0000FF",
marker=list(
radius=3
),
data=makeHighchartsPoints(
x=fmat[downupstat,1],
y=fmat[downupstat,2],
a=unname(altNames[downupstat])
)
)
}
if (length(updown)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Up-down-regulated",
color="#C68100",
marker=list(
radius=2
),
data=makeHighchartsPoints(
x=fmat[updown,1],
y=fmat[updown,2],
a=unname(altNames[updown])
)
)
}
if (length(downup)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Down-up-regulated",
color="#0000AB",
marker=list(
radius=2
),
data=makeHighchartsPoints(
x=fmat[downup,1],
y=fmat[downup,2],
a=unname(altNames[downup])
)
)
}
if (length(poor)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significant only",
color="#1F1F1F",
data=makeHighchartsPoints(
x=fmat[poor,1],
y=fmat[poor,2],
a=unname(altNames[poor])
)
)
}
if (length(neutral)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Neutral",
color="#00DADE",
data=makeHighchartsPoints(
x=fmat[neutral,1],
y=fmat[neutral,2],
a=unname(altNames[neutral])
)
)
}
if (length(nones)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="No regulation",
color="#CCCCCC",
data=makeHighchartsPoints(
x=fmat[nones,1],
y=fmat[nones,2],
a=unname(altNames[nones])
)
)
}
# Add fold lines
counter <- counter + 1
series[[counter]] <- list(
name="X up fold threshold",
color="#000000",
type="line",
dashStyle="Dash",
lineWidth=1,
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste('<strong>{series.name}',
'</strong><br/>',sep=""),
pointFormat=paste('<strong>Threshold: ',
'</strong>{point.x}<br/>',sep="")
),
data=list(round(c(fcut,floor(ylim[1])),3),
round(c(fcut,ceiling(ylim[2])),3))
)
counter <- counter + 1
series[[counter]] <- list(
name="X down fold threshold",
color="#000000",
type="line",
dashStyle="Dash",
lineWidth=1,
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste('<strong>{series.name}',
'</strong><br/>',sep=""),
pointFormat=paste('<strong>Threshold: ',
'</strong>{point.x}<br/>',sep="")
),
data=list(round(c(-fcut,floor(ylim[1])),3),
round(c(-fcut,ceiling(ylim[2])),3))
)
counter <- counter + 1
series[[counter]] <- list(
name="Y up fold threshold",
color="#000000",
type="line",
dashStyle="Dash",
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste('<strong>{series.name}',
'</strong><br/>',sep=""),
pointFormat=paste('<strong>Threshold: ',
'</strong>{point.y}<br/>',sep="")
),
data=list(round(c(floor(xlim[1]),fcut),3),
round(c(ceiling(xlim[2]),fcut),3))
)
counter <- counter + 1
series[[counter]] <- list(
name="Y down fold threshold",
color="#000000",
type="line",
dashStyle="Dash",
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste('<strong>{series.name}',
'</strong><br/>',sep=""),
pointFormat=paste('<strong>Threshold: ',
'</strong>{point.y}<br/>',sep="")
),
data=list(round(c(floor(xlim[1]),-fcut),3),
round(c(ceiling(xlim[2]),-fcut),3))
)
if (is.null(altNames))
point.format=paste("<strong>Gene ID: </strong>{point.name}<br>",
"<strong>Fold change X: </strong>{point.x}<br>",
"<strong>Fold change Y: </strong>{point.y}<br>",sep="")
else
point.format=paste("<strong>Gene name: </strong>",
"{point.alt_name}<br>",
"<strong>Gene ID: </strong>{point.name}<br>",
"<strong>Fold change X: </strong>{point.x}<br>",
"<strong>Fold change Y: </strong>{point.y}<br>",sep="")
json <- list(
chart=list(
type="scatter",
zoomType="xy"
),
title=list(
text=paste("Deregulogram")
),
xAxis=list(
title=list(
text=paste0("Fold change (log<sub>2</sub>)",conlabX),
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(xlim[1],3),
max=round(xlim[2],3)
),
yAxis=list(
title=list(
useHTML=TRUE,
text=paste0("Fold change (log<sub>2</sub>)",conlabY),
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(ylim[1],3),
max=round(ylim[2],3)
),
plotOptions=list(
scatter=list(
allowPointSelect=TRUE,
marker=list(
radius=2,
symbol="circle",
states=list(
hover=list(
enabled=TRUE,
lineColor="#333333"
)
)
),
states=list(
hover=list(
marker=list(
enabled=FALSE
)
)
),
tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=point.format
),
turboThreshold=50000
)
),
series=series
)
}
)
if (out == "json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out == "list")
return(json)
}
.unquote_js_fun <- function(js) {
if (is.list(js))
js <- lapply(js,.unquote_js_fun)
else {
op <- gregexpr(pattern="function",js)
cl <- gregexpr(pattern="}\\\"",js)
if (length(op)>0) {
starts <- as.numeric(op[[1]])
for (i in seq_len(length(starts)))
substr(js,starts[i]-1,starts[i]-1) <- " "
ends <- as.numeric(cl[[1]])
for (i in seq_len(length(starts)))
substr(js,ends[i]+1,ends[i]+1) <- " "
}
}
return(js)
}
.getGroupColorScheme <- function(group) {
cols <- .getColorScheme(length(group))
classes <- as.factor(asClassVector(group))
design <- as.numeric(classes)
return(lapply(cols,function(x,classes,design) {
return(x[seq_len(length(levels(classes)))][design])
},classes,design))
}
.getColorScheme <- function(n=NULL) {
if (missing(n) || is.null(n))
return(.getColors())
else {
cols <- .getColors()
if (n > length(cols$fill)) {
cols$fill <- rep(cols$fill,length.out=n)
cols$border <- rep(cols$border,length.out=n)
cols$select <- rep(cols$select,length.out=n)
cols$trans <- rep(cols$trans,length.out=n)
}
return(cols)
}
}
.getColors <- function() {
return(list(
fill=c("#CD0000","#00CD00","#0000EE","#FFD700","#87CEEB","#CD8500",
"#DEB887","#FF0000","#0000FF","#00FF00","#FFA500","#A9A9A9",
"#008B00","#313131","#FFC0CB","#A52A2A","#FF00FF","#9ACD32",
"#8B636C","#2E8B57","#008B8B"),
border=c("#850000","#006B00","#000085","#927C00","#156280","#5A3A00",
"#8B7457","#935E18","#000080","#008500","#603E00","#454545",
"#073E07","#000000","#896067","#691111","#7C007C","#3A4D14",
"#5B1726","#0C2517","#062A2A"),
selected=c("#FF0000","#00FF00","#0066FF","#FFD700","#FFEB77","#FFB428",
"#FFD9A5","#FF326D","#0089FF","#B3FF00","#FFC352","#D9D9D9",
"#00EC00","#8E8E8E","#FFDAE0","#F94444","#FF87FF","#C2FF45",
"#EA889D","#4EE590","#00DADA"),
trans=c("rgba(205,0,0,0.6)","rgba(0,205,0,0.6)","rgba(0,0,238,0.6)",
"rgba(255,215,0,0.6)","rgba(135,206,235,0.6)","rgba(205,133,0,0.6)",
"rgba(222,184,135,0.6)","rbga(255,0,0,0.5)","rgba(0,0,255,0.5)",
"rgba(0,255,0,0.5)","rgba(255,165,0,0.6)","rgba(169,169,169,0.5)",
"rgba(0,139,0,0.6)","rgba(49,49,49,0.6)","rgba(255,192,203,0.5)",
"rgba(165,42,42,0.6)","rgba(255,0,255,0.6)","rgba(154,205,50,0.6)",
"rgba(139,99,108,0.6)","rgba(46,139,87,0.6)","rgba(0,139,139,0.6)")
))
}
.getStatMap <- function() {
return(list(
deseq="DEseq",
deseq2="DEseq2",
edger="edgeR",
limma="voom",
nbpseq="NBPSeq",
noiseq="NOISeq",
#bayseq="baySeq",
absseq="ABSSeq",
dss="DSS"
))
}
pmoulos/metaseqR2-local documentation built on May 21, 2024, 3:46 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 .getStatMap .getColors .getColorScheme .getGroupColorScheme .unquote_js_fun dereguloToJSON maStatToJSON biodistToJSON rnacompToJSON scatterToJSON volcanoToJSON filteredToJSON biasPlotToJSON boxplotToJSON readNoiseToJSON bioSaturationToJSON bioDetectionToJSON countsBioToJSON mdsToJSON
mdsToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- out[1]
x <- obj$x
y <- obj$y
xlim <- obj$xlim
ylim <- obj$ylim
samples <- obj$samples
cols <- .getColorScheme()
# Construct series
counter <- 0
series <- vector("list",length(samples))
names(series) <- names(samples)
for (n in names(series)) {
counter <- counter + 1
series[[n]] <- list()
series[[n]]$name=n
series[[n]]$type="scatter"
series[[n]]$color=cols$fill[counter]
series[[n]]$marker <- list(
lineWidth=1,
states=list(
hover=list(
enabled=TRUE,
lineColor=cols$border[counter]
),
select=list(
fillColor=cols$selected[counter],
lineColor=cols$border[counter],
lineWidth=2
)
)
)
m <- match(samples[[n]],names(x))
if (length(m)>0) {
series[[n]]$data <- makeHighchartsPoints(x[m],y[m])
}
}
switch(jl,
highcharts = {
point.format=paste("<strong>Sample name: </strong>{point.name}<br>",
"<strong>Principal coordinate 1: </strong>{point.x}<br>",
"<strong>Principal coordinate 2: </strong>{point.y}",sep="")
json <- list(
chart=list(
type="scatter",
zoomType="xy"
),
title=list(
text=paste("Multidimensional Scaling")
),
xAxis=list(
title=list(
useHTML=TRUE,
text="1<sup>st</sup> Principal Coordinate",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(xlim[1],3),
max=round(xlim[2],3)
),
yAxis=list(
title=list(
useHTML=TRUE,
text="2<sup>nd</sup> Principal Coordinate",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(ylim[1],3),
max=round(ylim[2],3)
),
plotOptions=list(
scatter=list(
allowPointSelect=TRUE,
tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=point.format
)
)
),
series=unname(series)
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else
return(json)
}
countsBioToJSON <- function(obj,by=c("sample","biotype"),jl=c("highcharts"),
out=c("json","list")) {
by <- tolower(by[1])
jl <- tolower(jl[1])
out <- tolower(out[1])
samples <- obj$samples
status <- obj$status
altnames <- obj$altnames
counts <- round(2^obj$user$counts - 1)
#counts[counts==0] <- 0.001
counts <- counts + 1 # Offset for log
#counts <- obj$user$counts
covars <- obj$user$covars
biotypes <- unique(as.character(covars$biotype))
if (!is.null(altnames))
names(altnames) <- rownames(counts)
grouped <- FALSE
if (is.null(samples)) {
if (is.null(colnames(counts)))
samplenames <- paste("Sample",seq_len(ncol(counts)),sep=" ")
else
samplenames <- colnames(counts)
samples <- list(Samples=samplenames)
}
else if (is.list(samples)) {
samplenames <- unlist(samples,use.names=FALSE)
grouped <- TRUE
}
# y label formatter for logarithmic axis
y.label.formatter <- paste('function() {if(this.value === 0.001)',
'{return 0;} else {return Highcharts.Axis.prototype.',
'defaultLabelFormatter.call(this);}}',sep="")
tooltip.point.formatter <- paste("function() {",
" var min = this.low === 0.001 ? 0 : this.low;" ,
" var q1 = this.q1 === 0.001 ? 0 : this.q1;" ,
" var med = this.median === 0.001 ? 0 : this.median;",
" var q3 = this.q3 === 0.001 ? 0 : this.q3;",
" var max = this.high === 0.001 ? 0 : this.high;",
" var str = 'Maximum: ' + max + '<br/>' +",
" 'Upper quartile: ' + q3 + '<br/>' +",
" 'Median: ' + med + '<br/>' +",
" 'Lower quartile: ' + q1 + '<br/>' +",
" 'Minimum: ' + min + '<br/>';",
" return str;",
"}",sep="")
# Legend clicker
boxplot.onclick <- paste("function() { ",
" var chart = this.chart;",
" var outlier_id = chart.get(this.name);",
" if (!outlier_id.visible) {",
" outlier_id.show();",
" } else {",
" outlier_id.hide();",
" }",
"}",sep="")
# Outliers tooltip
if (is.null(obj$altnames)) {
outlier.pointformat <- paste(
'<strong>Sample {point.category}</strong><br/>',
'Gene ID: {point.name}<br/>',
'Value: {point.y}<br/>',sep=""
)
}
else {
outlier.pointformat <- paste(
'<strong>Sample {point.category}</strong><br/>',
'Gene ID: {point.name}<br/>',
'Gene name: {point.alt_name}<br/>',
'Value: {point.y}<br/>',
sep=""
)
}
if (by=="sample") {
cols <- .getColorScheme(length(biotypes))
boxList <- json <- vector("list",length(samplenames))
names(boxList) <- names(json) <- samplenames
for (n in samplenames) {
boxList[[n]] <- vector("list",length(biotypes))
names(boxList[[n]]) <- biotypes
for (b in biotypes)
boxList[[n]][[b]] <- counts[covars$biotype==b,n]
B <- boxplot(boxList[[n]],plot=FALSE)$stats
colnames(B) <- biotypes
oList <- lapply(names(boxList[[n]]),function(x,M,b) {
v <- b[,x]
o <- which(M[[x]]<v[1] | M[[x]]>v[5])
if (length(o)>0)
return(M[[x]][o])
else
return(NULL)
},boxList[[n]],B)
names(oList) <- biotypes
# Data series
BB <- matrix(0,nrow(B),ncol(B)) # Workaround of strange problem...
colnames(BB) <- colnames(B)
for (jj in seq_len(ncol(B)))
BB[,jj] <- round(B[,jj],3)
d <- as.data.frame(BB)
ids <- 0:(ncol(d)-1)
d <- rbind(ids,d)
names(ids) <- colnames(d)
counter <- 0
series <- vector("list",length(biotypes))
names(series) <- biotypes
for (s in names(series)) {
counter <- counter + 1
series[[s]] <- list()
series[[s]]$name <- s
series[[s]]$color <- cols$fill[counter]
series[[s]]$data <- list(unname(as.list(d[,s])))
r <- round(d[,s])
series[[s]]$tooltip=list(
pointFormat=paste('<strong>Population: ',
length(boxList[[n]][[s]]),'</strong><br/>',
'Maximum: ',r[6],'<br/>',
'Upper quartile: ',r[5],'<br/>',
'Median: ',r[4],'<br/>',
'Lower quartile: ',r[3],'<br/>',
'Minimum: ',r[2],'<br/>',sep="")
)
}
# Outlier series (if any)
counter <- 0
outliers <- vector("list",length(biotypes))
names(outliers) <- biotypes
for (o in names(outliers)) {
counter <- counter + 1
outliers[[o]] <- list()
outliers[[o]]$id <- o
outliers[[o]]$name <- o
outliers[[o]]$type <- "scatter"
outliers[[o]]$showInLegend <- FALSE
outliers[[o]]$color <- cols$fill[counter]
outliers[[o]]$marker <- list(
fillColor=cols$fill[counter],
symbol="circle",
lineWidth=1,
lineColor=cols$border[counter]
)
outliers[[o]]$data <- list()
x <- rep(d[1,o],length(oList[[o]]))
names(x) <- names(oList[[o]])
if (is.null(obj$altnames)) {
outliers[[o]]$data <-
makeHighchartsPoints(x,oList[[o]])
}
else {
outliers[[o]]$data <-
makeHighchartsPoints(x,oList[[o]],
unname(altnames[names(x)]))
}
}
json[[n]] <- switch(jl,
highcharts = {
list(
chart=list(
type="boxplot"
),
title=list(
text=paste("Biotype detection for sample ",n,
sep="")
),
legend=list(
enabled=TRUE,
itemHoverStyle=list(
color="#B40000"
)
),
xAxis=list(
categories=biotypes,
title=list(
text="Biotype",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
)
),
yAxis=list(
type="logarithmic",
showFirstLabel=FALSE,
min=1e-4,
tickInterval=1,
title=list(
useHTML=TRUE,
#text="Read count (log<sub>2</sub>)",
text="Expression (read count)",
margin=25,
style=list(
color="#000000",
fontSize="1.1em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
),
formatter=y.label.formatter
)
),
plotOptions=list(
boxplot=list(
fillColor="#F0F0E0",
lineWidth=2,
medianColor="#000000",
medianWidth=3,
stemColor="#000000",
stemDashStyle="dash",
stemWidth=1,
whiskerColor="#000000",
whiskerLength="75%",
whiskerWidth=1,
grouping=FALSE,
turboThreshold=10000,
tooltip=list(
headerFormat=paste(
'<span style="font-size:1.1em;',
'color:{series.color};',
'font-weight:bold">',
'\u25CF </span>',
'<span style="font-size:1.1em;',
'font-weight:bold">',
'Biotype {series.name}</span><br/>',
sep=""
)
),
events=list(
legendItemClick=boxplot.onclick
)
),
scatter=list(
allowPointSelect=TRUE,
turboThreshold=10000,
tooltip=list(
headerFormat=paste(
'<span style="font-weight:bold;',
'color:{series.color};">',
'\u25CF </span>',
'<span style="font-weight:bold">',
'Biotype {series.name}</span><br/>',
sep=""
),
pointFormat=outlier.pointformat
),
states=list(
hover=list(
marker=list(
enabled=FALSE
)
)
)
)
),
series=c(unname(series),unname(outliers))
)
}
)
}
if (out=="json") {
for (i in seq_along(json))
#json[[i]] <- .unquote_js_fun(toJSON(json[[i]],
# auto_unbox=TRUE,null="null"))
json[[i]] <- toJSON(json[[i]],auto_unbox=TRUE,null="null")
return(json)
}
else
return(json)
}
else if (by=="biotype") {
cols <- .getColorScheme(length(samples))
boxList <- json <- vector("list",length(biotypes))
names(boxList) <- names(json) <- biotypes
for (b in biotypes) {
boxList[[b]] <- vector("list",length(samplenames))
names(boxList[[b]]) <- samplenames
for (n in samplenames)
boxList[[b]][[n]] <- counts[covars$biotype==b,n]
B <- boxplot(boxList[[b]],plot=FALSE)$stats
colnames(B) <- samplenames
oList <- lapply(names(boxList[[b]]),function(x,M,b) {
v <- b[,x]
o <- which(M[[x]]<v[1] | M[[x]]>v[5])
if (length(o)>0)
return(M[[x]][o])
else
return(NULL)
},boxList[[b]],B)
names(oList) <- samplenames
# Data series
BB <- matrix(0,nrow(B),ncol(B)) # Workaround of strange problem...
colnames(BB) <- colnames(B)
for (jj in seq_len(ncol(B)))
BB[,jj] <- round(B[,jj],3)
d <- as.data.frame(BB)
ids <- 0:(ncol(d)-1)
d <- rbind(ids,d)
names(ids) <- colnames(d)
counter <- 0
series <- vector("list",length(samples))
names(series) <- names(samples)
for (s in names(series)) {
counter <- counter + 1
series[[s]] <- list()
series[[s]]$name=s
if (grouped)
series[[s]]$color=cols$fill[counter]
else
series[[s]]$color=cols$fill[1]
m <- match(samples[[s]],colnames(d))
if (length(m) > 1)
series[[s]]$data <- unname(as.list(d[,m]))
else
series[[s]]$data <- list(unname(as.list(d[,m])))
}
# Outlier series (if any)
counter <- 0
outliers <- vector("list",length(samples))
names(outliers) <- names(samples)
for (o in names(outliers)) {
counter <- counter + 1
outliers[[o]] <- list()
outliers[[o]]$id <- o
outliers[[o]]$name <- o
outliers[[o]]$type <- "scatter"
outliers[[o]]$showInLegend <- FALSE
if (grouped) {
outliers[[o]]$color <- cols$fill[counter]
outliers[[o]]$marker <- list(
fillColor=cols$fill[counter],
symbol="circle",
lineWidth=1,
lineColor=cols$border[counter]
)
}
else {
outliers[[o]]$color <- cols$fill[1]
outliers[[o]]$marker <- list(
fillColor=cols$fill[1],
symbol="circle",
lineWidth=1,
lineColor=cols$border[1]
)
}
outliers[[o]]$data <- list()
m <- match(samples[[o]],colnames(d))
if (length(m)>0) {
for (i in m) {
x <- rep(d[1,i],length(oList[[i]]))
names(x) <- names(oList[[i]])
if (is.null(obj$altnames)) {
outliers[[o]]$data <-
makeHighchartsPoints(x,oList[[i]])
}
else {
outliers[[o]]$data <- c(outliers[[o]]$data,
makeHighchartsPoints(x,oList[[i]],
unname(altnames)))
}
}
}
}
json[[b]] <- switch(jl,
highcharts = {
list(
chart=list(
type="boxplot"
),
title=list(
text=paste("Detection for biotype ",b,
" (population: ",lengths(boxList[[b]])[1],
")",sep="")
),
legend=list(
enabled=TRUE
),
xAxis=list(
categories=samplenames,
title=list(
text="Sample name",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
)
),
yAxis=list(
type="logarithmic",
showFirstLabel=FALSE,
min=1e-4,
tickInterval=1,
title=list(
text="Expression (read count)",
margin=25,
style=list(
color="#000000",
fontSize="1.1em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
),
formatter=y.label.formatter
)
),
plotOptions=list(
boxplot=list(
fillColor="#F0F0E0",
lineWidth=2,
medianColor="#000000",
medianWidth=3,
stemColor="#000000",
stemDashStyle="dash",
stemWidth=1,
whiskerColor="#000000",
whiskerLength="75%",
whiskerWidth=1,
grouping=FALSE,
turboThreshold=10000,
tooltip=list(
headerFormat=paste(
'<span style="font-size:1.1em;',
'color:{series.color};',
'font-weight:bold">',
'\u25CF </span>',
'<span style="font-size:1.1em;',
'font-weight:bold">',
'Condition {series.name}</span>',
'<br/>',
'<span style="font-weight:bold;">',
'Sample {point.key}',
'</span><br/>',sep=""
),
pointFormatter=tooltip.point.formatter
),
events=list(
legendItemClick=boxplot.onclick
)
),
scatter=list(
allowPointSelect=TRUE,
turboThreshold=10000,
tooltip=list(
headerFormat=paste(
'<span style="font-weight:bold;',
'color:{series.color};">',
'\u25CF </span>',
'<span style="font-weight:bold">',
'Condition {series.name}</span>',
'<br/>',sep=""
),
pointFormat=outlier.pointformat
),
states=list(
hover=list(
marker=list(
enabled=FALSE
)
)
)
)
),
series=c(unname(series),unname(outliers))
)
}
)
}
if (out=="json") {
for (i in seq_along(json))
#json[[i]] <- .unquote_js_fun(toJSON(json[[i]],
# auto_unbox=TRUE,null="null"))
json[[i]] <- toJSON(json[[i]],auto_unbox=TRUE,null="null")
return(json)
}
else
return(json)
}
}
bioDetectionToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- tolower(out[1])
samples <- obj$samples
status <- obj$status
plotdata <- obj$user$plotdata
covars <- obj$user$covars
if (!is.null(samples) && is.list(samples)) {
samplenames <- unlist(samples,use.names=FALSE)
names(plotdata$biotables) <- samplenames
}
# Otherwise we are using the names present in the input object
abu <- which(plotdata$genome>7)
nabu <- which(plotdata$genome<=7)
cols <- .getColorScheme()
json <- vector("list",length(samplenames))
names(json) <- samplenames
for (n in samplenames) {
# Data series
seriesAbu <- vector("list",3)
names(seriesAbu) <- c("genome","detectionVSgenome","detectionVSsample")
seriesAbu$genome <- list()
seriesAbu$genome$id <- "abu_genome"
seriesAbu$genome$name <- "% in genome"
seriesAbu$genome$color <- cols$trans[1]
seriesAbu$genome$pointPlacement <- -0.2
seriesAbu$genome$data <- round(as.numeric(plotdata$genome[abu]),3)
seriesAbu$detectionVSgenome <- list()
seriesAbu$detectionVSgenome$id <- "abu_detected"
seriesAbu$detectionVSgenome$name <- "% detected"
seriesAbu$detectionVSgenome$color <- cols$trans[2]
seriesAbu$detectionVSgenome$pointPlacement <- 0
seriesAbu$detectionVSgenome$data <- round(as.numeric(
plotdata$biotables[[n]][1,abu]),3)
seriesAbu$detectionVSsample <- list()
seriesAbu$detectionVSsample$id <- "abu_sample"
seriesAbu$detectionVSsample$name <- "% in sample"
seriesAbu$detectionVSsample$color <- cols$trans[3]
seriesAbu$detectionVSsample$pointPlacement <- 0.2
seriesAbu$detectionVSsample$data <- round(as.numeric(
plotdata$biotables[[n]][2,abu]),3)
seriesNabu <- vector("list",3)
names(seriesNabu) <- c("genome","detectionVSgenome",
"detectionVSsample")
seriesNabu$genome <- list()
seriesNabu$genome$name <- "% in genome"
seriesNabu$genome$yAxis <- 1
seriesNabu$genome$pointStart <- length(abu)
seriesNabu$genome$linkedTo <- "abu_genome"
seriesNabu$genome$color <- cols$trans[1]
seriesNabu$genome$pointPlacement <- -0.2
seriesNabu$genome$data <- round(as.numeric(plotdata$genome[nabu]),3)
seriesNabu$detectionVSgenome <- list()
seriesNabu$detectionVSgenome$name <- "% detected"
seriesNabu$detectionVSgenome$yAxis <- 1
seriesNabu$detectionVSgenome$pointStart <- length(abu)
seriesNabu$detectionVSgenome$linkedTo <- "abu_detected"
seriesNabu$detectionVSgenome$color <- cols$trans[2]
seriesNabu$detectionVSgenome$pointPlacement <- 0
seriesNabu$detectionVSgenome$data <- round(as.numeric(
plotdata$biotables[[n]][1,nabu]),3)
seriesNabu$detectionVSsample <- list()
seriesNabu$detectionVSsample$name <- "% in sample"
seriesNabu$detectionVSsample$yAxis <- 1
seriesNabu$detectionVSsample$pointStart <- length(abu)
seriesNabu$detectionVSsample$linkedTo <- "abu_sample"
seriesNabu$detectionVSsample$color <- cols$trans[3]
seriesNabu$detectionVSsample$pointPlacement <- 0.2
seriesNabu$detectionVSsample$data <- round(as.numeric(
plotdata$biotables[[n]][2,nabu]),3)
json[[n]] <- switch(jl,
highcharts = {
list(
chart=list(
type="column",
alignTicks=FALSE
),
title=list(
text=paste("Comparative biotype detection for ",
"sample ",n,sep="")
),
legend=list(
enabled=TRUE,
itemHoverStyle=list(
color="#B40000"
)
),
tooltip=list(
shared=TRUE
),
xAxis=list(
categories=names(plotdata$genome)[c(abu,nabu)],
title=list(
text="Biotype",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
),
plotLines=list(
list(
color="#8A8A8A",
width=1.5,
dashStyle="Dash",
value=length(abu)-0.5
)
),
plotBands=list(
list(
color="#FFFFE0",
from=-0.5,
to=length(abu)-0.5
),
list(
color="#FFECEB",
from=length(abu)-0.5,
to=length(plotdata$genome)
)
)
),
yAxis=list(
list(
min=0,
max=70,
title=list(
text="% of abundant features",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
)
),
list(
min=0,
max=7,
title=list(
text="% of non-abundant features",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
opposite=TRUE
)
),
plotOptions=list(
column=list(
grouping=FALSE,
shadow=FALSE,
groupPadding=0.3,
pointPadding=0.25,
tooltip=list(
headerFormat=paste(
'<span style="font-size:1.1em;',
'font-weight:bold">',
'{point.key}</span><br/>',sep=""
)
)
)
),
series=c(unname(seriesAbu),unname(seriesNabu))
)
}
)
}
if (out=="json") {
for (i in seq_along(json))
json[[i]] <- toJSON(json[[i]],auto_unbox=TRUE,null="null")
return(json)
}
else if (out=="list")
return(json)
}
bioSaturationToJSON <- function(obj,by=c("sample","biotype"),
jl=c("highcharts"),out=c("json","list")) {
by <- tolower(by[1])
jl <- tolower(jl[1])
out <- tolower(out[1])
samples <- obj$samples
plotdata <- obj$user$plotdata
if (!is.null(samples)&& is.list(samples)) {
samplenames <- unlist(samples,use.names=FALSE)
names(plotdata) <- samplenames
}
if (by=="sample") {
json <- vector("list",length(samplenames))
names(json) <- samplenames
for (n in samplenames) {
depth <- round(plotdata[[n]][,1]/1e+6)
global <- round(plotdata[[n]][,2])
M <- plotdata[[n]][,3:ncol(plotdata[[n]]),drop=FALSE]
# To determine the separation
ord <- sort(M[nrow(M),],decreasing=TRUE,index.return=TRUE)
abu <- ord$ix[c(1,2)]
names(abu) <- names(ord$x[c(1,2)])
nabu <- ord$ix[3:length(ord$ix)]
names(nabu) <- names(ord$x[3:length(ord$x)])
cols <- .getColorScheme(ncol(plotdata[[n]])-1)
counter <- 1
global.series <- list(
global=list(
id="global",
name="global",
color=cols$fill[counter],
data=makeHighchartsPoints(depth,global)
)
)
abuSeries <- vector("list",2)
names(abuSeries) <- names(abu)
for (s in names(abuSeries)) {
counter <- counter + 1
abuSeries[[s]] <- list()
abuSeries[[s]]$id <- s
abuSeries[[s]]$name <- s
abuSeries[[s]]$color <- cols$fill[counter]
abuSeries[[s]]$data <- makeHighchartsPoints(depth,
round(M[,s]))
}
nabuSeries <- vector("list",length(3:ncol(M)))
names(nabuSeries) <- names(nabu)
for (s in names(nabuSeries)) {
counter <- counter + 1
nabuSeries[[s]] <- list()
nabuSeries[[s]]$id <- s
nabuSeries[[s]]$name <- s
nabuSeries[[s]]$color <- cols$fill[counter]
nabuSeries[[s]]$data <- makeHighchartsPoints(depth,
round(M[,s]))
}
json[[n]] <- switch(jl,
highcharts = {
list(
chart=list(
type="scatter",
zoomType="xy"
),
title=list(
text=paste("Biotype saturations for sample ",n,
sep="")
),
legend=list(
enabled=TRUE,
itemHoverStyle=list(
color="#B40000"
)
),
xAxis=list(
title=list(
text="Read depth (millions of reads)",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
)
),
yAxis=list(
min=0,
max=max(global),
title=list(
text="Detected features",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
)
),
plotOptions=list(
series=list(
lineWidth=2
),
scatter=list(
tooltip=list(
headerFormat=paste(
'<span style="font-weight:bold;',
'color:{series.color};">',
'\u25CF </span>',
'<span style="font-weight:bold">',
'Biotype {series.name}</span><br/>',
sep=""
),
pointFormat=paste(
"Depth: {point.x}M<br/>",
"Detected features: {point.y}",
sep="")
)
)
),
series=c(unname(global.series),
unname(abuSeries),unname(nabuSeries))
)
}
)
}
if (out=="json") {
for (i in seq_along(json))
json[[i]] <- toJSON(json[[i]],auto_unbox=TRUE,null="null")
return(json)
}
else if (out=="list")
return(json)
}
else if (by=="biotype") {
biotypes <- colnames(plotdata[[1]])[2:ncol(plotdata[[1]])]
depths <- vector("list",length(plotdata))
names(depths) <- samplenames
for (n in samplenames)
depths[[n]] <- round(plotdata[[n]][,1]/1e+6)
json <- vector("list",length(biotypes))
names(json) <- biotypes
for (b in biotypes) {
series <- vector("list",length(plotdata))
names(series) <- samplenames
cols <- .getColorScheme(length(samplenames))
counter <- 0
for (s in names(series)) {
counter <- counter + 1
series[[s]] <- list()
series[[s]]$id <- s
series[[s]]$name <- s
series[[s]]$color <- cols$fill[counter]
series[[s]]$data <- makeHighchartsPoints(depths[[s]],
round(plotdata[[s]][,b]))
}
json[[b]] <- switch(jl,
highcharts = {
list(
chart=list(
type="scatter",
zoomType="xy"
),
title=list(
text=paste("Sample saturations for biotype ",b,
sep="")
),
legend=list(
enabled=TRUE,
itemHoverStyle=list(
color="#B40000"
)
),
xAxis=list(
title=list(
text="Read depth (millions of reads)",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
)
),
yAxis=list(
title=list(
text="Detected features",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
)
),
plotOptions=list(
series=list(
lineWidth=2
),
scatter=list(
tooltip=list(
headerFormat=paste(
'<span style="font-weight:bold;',
'color:{series.color};">',
'\u25CF </span>',
'<span style="font-weight:bold">',
'Sample {series.name}</span><br/>',
sep=""
),
pointFormat=paste(
"Depth: {point.x}M<br/>",
"Detected features: {point.y}",
sep="")
)
)
),
series=c(unname(series))
)
}
)
}
if (out=="json") {
for (i in seq_along(json))
json[[i]] <- toJSON(json[[i]],auto_unbox=TRUE,null="null")
return(json)
}
else if (out=="list") {
names(json) <- biotypes
return(json)
}
}
}
readNoiseToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- tolower(out[1])
d <- obj$user
samples <- obj$samples
# Too many points for a lot of curves of interactive data
if (nrow(d)>1000) {
ii <- sort(sample(seq_len(nrow(d)),998))
ii <- c(1,ii,nrow(d))
d <- cbind(d[ii,1],d[ii,2:ncol(d)])
}
if (is.null(samples))
samples <- seq_len((ncol(d)-1))
if (is.numeric(samples))
samplenames = colnames(dat)[samples+1]
if (is.list(samples))
samplenames <- unlist(samples)
cols <- .getColorScheme(length(samplenames))
# Construct series
counter <- 0
series <- vector("list",length(samplenames))
names(series) <- samplenames
for (n in names(series)) {
counter <- counter + 1
series[[n]] <- list()
series[[n]]$name=n
series[[n]]$color=cols$fill[counter]
series[[n]]$data <- makeHighchartsPoints(d[,1],d[,n],simple=TRUE)
series[[n]]$tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=NULL
)
}
switch(jl,
highcharts = {
json <- list(
chart=list(
type="line",
zoomType="xy"
),
title=list(
text=paste("RNA-Seq mapped reads noise")
),
xAxis=list(
title=list(
text="% detected features",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=0,
max=100
),
yAxis=list(
title=list(
text="% of total reads",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
tickPositions=seq(0,110,10)
),
plotOptions=list(
line=list(
allowPointSelect=TRUE,
lineWidth=1,
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=NULL
),
turboThreshold=50000
)
),
series=unname(series)
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out=="list")
return(json)
}
boxplotToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- tolower(out[1])
b <- obj$plot
name <- obj$samples
status <- obj$status
altnames <- obj$altnames
oList <- obj$user
grouped <- FALSE
if (is.null(name)) {
if (is.null(colnames(b$stats)))
nams <- paste("Sample",seq_len(ncol(b$stats)),sep=" ")
else
nams <- colnames(b$stats)
name <- list(Samples=nams)
}
else if (length(name)==1 && name=="none") {
nams <- rep("",ncol(b$stats))
name <- list(Samples=nams)
}
else if (is.list(name)) { # Is sampleList
nams <- unlist(name,use.names=FALSE)
grouped <- TRUE
}
cols <- .getColorScheme()
# Data series
d <- as.data.frame(round(b$stat,3))
ids <- 0:(ncol(d)-1)
d <- rbind(ids,d)
colnames(d) <- nams
names(ids) <- colnames(d)
counter <- 0
series <- vector("list",length(name))
names(series) <- names(name)
for (n in names(series)) {
counter <- counter + 1
series[[n]] <- list()
series[[n]]$name=n
if (grouped)
series[[n]]$color=cols$fill[counter]
else
series[[n]]$color=cols$fill[1]
m <- match(name[[n]],colnames(d))
if (length(m) > 1)
series[[n]]$data <- unname(as.list(d[,m]))
else
series[[n]]$data <- list(unname(as.list(d[,m])))
}
# Outlier series (if any)
counter <- 0
outliers <- vector("list",length(name))
names(outliers) <- names(name)
for (n in names(outliers)) {
counter <- counter + 1
outliers[[n]] <- list()
outliers[[n]]$id <- n
outliers[[n]]$name <- n
outliers[[n]]$type <- "scatter"
outliers[[n]]$showInLegend <- FALSE
if (grouped) {
outliers[[n]]$color <- cols$fill[counter]
outliers[[n]]$marker <- list(
fillColor=cols$fill[counter],
symbol="circle",
lineWidth=1,
lineColor=cols$border[counter]
)
}
else {
outliers[[n]]$color <- cols$fill[1]
outliers[[n]]$marker <- list(
fillColor=cols$fill[1],
symbol="circle",
lineWidth=1,
lineColor=cols$border[1]
)
}
outliers[[n]]$data <- list()
m <- match(name[[n]],colnames(d))
if (length(m)>0) {
for (i in m) {
x <- rep(d[1,i],length(oList[[i]]))
names(x) <- names(oList[[i]])
outliers[[n]]$data <- c(outliers[[n]]$data,
makeHighchartsPoints(x,oList[[i]],unname(altnames)))
}
}
}
# Boxplot tooltip point formatter for the case of zeros
tooltip.point.formatter <- paste("function() {",
" var min = this.low === 0.001 ? 0 : this.low;" ,
" var q1 = this.q1 === 0.001 ? 0 : this.q1;" ,
" var med = this.median === 0.001 ? 0 : this.median;",
" var q3 = this.q3 === 0.001 ? 0 : this.q3;",
" var max = this.high === 0.001 ? 0 : this.high;",
" var str = 'Maximum: ' + max + '<br/>' +",
" 'Upper quartile: ' + q3 + '<br/>' +",
" 'Median: ' + med + '<br/>' +",
" 'Lower quartile: ' + q1 + '<br/>' +",
" 'Minimum: ' + min + '<br/>';",
" return str;",
"}",sep="")
# Legend clicker
boxplot.onclick <- paste("function() {",
" var chart = this.chart;",
" var outlier_id = chart.get(this.name);",
" if (!outlier_id.visible) {",
" outlier_id.show();",
" } else {",
" outlier_id.hide();",
" }",
"}",sep="")
if (is.null(obj$altnames)) {
outlier.pointformat=paste(
'<strong>Sample {point.category}</strong><br/>',
'Gene ID: {point.name}<br/>',
'Value: {point.y}<br/>',sep=""
)
}
else {
outlier.pointformat=paste(
'<strong>Sample {point.category}</strong><br/>',
'Gene ID: {point.name}<br/>',
'Gene name: {point.alt_name}<br/>',
'Value: {point.y}<br/>',sep=""
)
}
json <- switch(jl,
highcharts = {
list(
chart=list(
type="boxplot"
),
title=list(
text=paste("Boxplot ",status,sep="")
),
legend=list(
enabled=TRUE
),
xAxis=list(
categories=nams,
title=list(
text="Sample name",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
)
),
yAxis=list(
title=list(
useHTML=TRUE,
text="Read count (log<sub>2</sub>)",
margin=30,
style=list(
color="#000000",
fontSize="1.1em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
)
),
plotOptions=list(
boxplot=list(
fillColor="#F0F0E0",
lineWidth=2,
medianColor="#000000",
medianWidth=3,
stemColor="#000000",
stemDashStyle="dash",
stemWidth=1,
whiskerColor="#000000",
whiskerLength="75%",
whiskerWidth=1,
grouping=FALSE,
tooltip=list(
headerFormat=paste(
'<span style="font-size:1.1em;',
'color:{series.color};',
'font-weight:bold">',
'\u25CF </span>',
'<span style="font-size:1.1em;',
'font-weight:bold">',
'Condition {series.name}</span><br/>',
'<span style="font-weight:bold">',
'Sample {point.key}</span><br/>',sep=""
),
pointFormatter=tooltip.point.formatter
),
events=list(
legendItemClick=boxplot.onclick
)
),
scatter=list(
allowPointSelect=TRUE,
tooltip=list(
headerFormat=paste(
'<span style="font-weight:bold;',
'color:{series.color};">',
'\u25CF </span>',
'<span style="font-weight:bold">',
'Condition {series.name}</span><br/>',
sep=""
),
pointFormat=outlier.pointformat
),
states=list(
hover=list(
marker=list(
enabled=FALSE
)
)
)
)
),
series=c(unname(series),unname(outliers))
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else
return(json)
}
biasPlotToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- tolower(out[1])
counts <- round(nat2log(obj$user$counts),3)
status <- obj$status
covar <- obj$user$covar
covarname <- obj$user$covarname
samples <- obj$samples
# Too many points for a lot of curves of interactive data
if (nrow(counts)>2000) {
#set.seed(seed)
ii <- sample(seq_len(nrow(counts)),2000)
counts <- counts[ii,]
covar <- covar[ii]
}
# If length bias, not nice to have x-axis at -200k
if (covarname == "lengthbias")
minX <- ifelse(max(covar>100),0,"undefined")
else
minX <- 0.1
if (is.null(samples)) {
if (is.null(colnames(x)))
samplenames <- paste("Sample",seq_len(ncol(counts)),sep=" ")
else
samplenames <- colnames(counts)
samples <- list(Samples=samplenames)
cols <- .getColorScheme(length(samples))
}
else if (is.list(samples)) { # Is sampleList
samplenames <- unlist(samples,use.names=FALSE)
grouped <- TRUE
cols <- .getColorScheme(length(samplenames))
}
colnames(counts) <- samplenames
# Construct series
counter <- 0
series <- vector("list",length(samplenames))
names(series) <- samplenames
for (n in names(series)) {
counter <- counter + 1
x <- counts[,n]
fit <- lowess(covar,x)
series[[n]] <- list()
series[[n]]$name <- n
series[[n]]$color <- cols$fill[counter]
series[[n]]$data <- lapply(seq_len(length(x)),function(i,x,y) {
return(c(x[i],y[i])) },round(fit$x,3),round(fit$y,3))
}
switch(jl,
highcharts = {
json <- list(
chart=list(
type="line",
zoomType="xy"
),
title=list(
text=paste(covarname," bias detection - ",status)
),
xAxis=list(
min=minX,
title=list(
text=covarname,
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE
),
yAxis=list(
title=list(
useHTML=TRUE,
text="Read count (log<sub>2</sub>)",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE
),
plotOptions=list(
line=list(
marker=list(
enabled=FALSE,
states=list(
hover=list(
enabled=FALSE
)
)
),
tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=NULL
),
turboThreshold=50000
)
),
series=unname(series)
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out=="list")
return(json)
}
filteredToJSON <- function(obj,by=c("chromosome","biotype"),
jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
by <- tolower(by[1])
out <- tolower(out[1])
filtered <- obj$user$filtered
total <- obj$user$total
cols <- .getColorScheme(2)
if (by=="chromosome") {
chrTab <- table(as.character(filtered$chromosome))
chr <- as.numeric(chrTab)
names(chr) <- names(chrTab)
chrAllTab <- table(as.character(total$chromosome))
chrAll <- as.numeric(chrAllTab)
names(chrAll) <- names(chrAllTab)
barlabChr <- as.character(chr)
perChr <- round(chr/chrAll[names(chr)],3)
perChr[perChr>1] <- 1
series <- vector("list",2)
names(series) <- c("number","fraction")
series$number <- list()
series$number$id <- "chr_number"
series$number$name <- "Number of genes"
series$number$color <- cols$fill[1]
series$number$pointPlacement <- -0.2
series$number$data <- unname(chr)
series$fraction <- list()
series$fraction$id <- "chr_fraction"
series$fraction$name <- "Fraction of total genes"
series$fraction$color <- cols$fill[2]
series$fraction$pointPlacement <- 0.2
series$fraction$yAxis <- 1
series$fraction$data <- unname(perChr)
what <- chr
}
else if (by=="biotype") {
btTab <- table(as.character(filtered$biotype))
bt <- as.numeric(btTab)
names(bt) <- names(btTab)
btAllTab <- table(as.character(total$biotype))
btAll <- as.numeric(table(as.character(total$biotype)))
names(btAll) <- names(btAllTab)
barlabBt <- as.character(bt)
perBt <- round(bt/btAll[names(bt)],3)
perBt[perBt>1] <- 1
series <- vector("list",2)
names(series) <- c("number","fraction")
series$number <- list()
series$number$id <- "bt_number"
series$number$name <- "Number of genes"
series$number$color <- cols$fill[1]
series$number$pointPlacement <- -0.2
series$number$data <- unname(bt)
series$fraction <- list()
series$fraction$id <- "bt_fraction"
series$fraction$name <- "Fraction of total genes"
series$fraction$color <- cols$fill[2]
series$fraction$pointPlacement <- 0.2
series$fraction$yAxis <- 1
series$fraction$data <- unname(perBt)
what <- bt
}
json <- switch(jl,
highcharts = {
list(
chart=list(
type="column",
alignTicks=FALSE
),
title=list(
text=paste("Filtered genes per ",by,sep="")
),
legend=list(
enabled=TRUE,
itemHoverStyle=list(
color="#B40000"
)
),
tooltip=list(
shared=TRUE
),
xAxis=list(
categories=names(what),
title=list(
text=paste(toupper(substr(by,1,1)),substr(by,2,
nchar(by)),sep=""),
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
)
),
yAxis=list(
list(
lineColor=cols$fill[1],
lineWidth=2,
min=0,
tickAmount=11,
title=list(
text="Number of genes",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
offset=10
),
list(
lineColor=cols$fill[2],
lineWidth=2,
min=0,
max=1,
tickAmount=11,
#tickInterval=0.1,
title=list(
text="Fraction of total genes",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
opposite=TRUE,
offset=10
)
),
plotOptions=list(
column=list(
grouping=FALSE,
shadow=FALSE,
groupPadding=0.2,
pointPadding=0.2,
tooltip=list(
headerFormat=paste(
'<span style="font-size:1.1em;',
'font-weight:bold">',
'{point.key}</span><br/>',sep=""
)
)
)
),
series=c(unname(series))
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out=="list")
return(json)
}
volcanoToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- tolower(out[1])
f <- obj$x
p <- obj$y
xlim <- obj$xlim
ylim <- obj$ylim
altNames <- obj$altnames
pcut <- obj$pcut
fcut <- obj$fcut
up <- obj$user$up
down <- obj$user$down
ff <- obj$user$unf
pp <- obj$user$unp
altNamesNeutrall <- obj$user$ualt
con <- obj$user$con
switch(jl,
highcharts = {
if (is.null(altNames))
point.format=paste("<strong>Gene ID: </strong>{point.name}<br>",
"<strong>Fold change: </strong>{point.x}<br>",
"<strong>Significance: </strong>{point.y}",sep="")
else
point.format=paste("<strong>Gene name: </strong>",
"{point.alt_name}<br>",
"<strong>Gene ID: </strong>{point.name}<br>",
"<strong>Fold change: </strong>{point.x}<br>",
"<strong>Significance: </strong>{point.y}",sep="")
json <- list(
chart=list(
type="scatter",
zoomType="xy"
),
title=list(
text=paste("Volcano plot for",con)
),
xAxis=list(
title=list(
text="Fold change",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(xlim[1],3),
max=round(xlim[2],3)
),
yAxis=list(
title=list(
useHTML=TRUE,
text="Significance (-log<sub>10</sub>(p-value))",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(ylim[1]-2,3),
max=round(ylim[2],3)
),
#legend=list(
# layout="vertical",
# align="left",
# verticalAlign="top",
# floating=TRUE,
# backgroundColor="#FFFFFF",
# borderWidth=1
#),
plotOptions=list(
scatter=list(
allowPointSelect=TRUE,
marker=list(
radius=2,
states=list(
hover=list(
enabled=TRUE,
lineColor="#333333"
)
)
),
states=list(
hover=list(
marker=list(
enabled=FALSE
)
)
),
tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=point.format
),
turboThreshold=50000
)
),
series=list(
list(
name="Up-regulated",
color="#EE0000",
marker=list(
symbol="circle"
),
data=makeHighchartsPoints(f[up],-log10(p[up]),
unname(altNames[up]))
),
list(
name="Down-regulated",
marker=list(
symbol="circle"
),
color="#00CD00",
data=makeHighchartsPoints(f[down],-log10(p[down]),
unname(altNames[down]))
),
list(
name="Unregulated",
marker=list(
symbol="circle"
),
color="#0000EE",
data=makeHighchartsPoints(ff,-log10(pp),
unname(altNamesNeutrall))
),
list(
name="Downfold threshold",
color="#000000",
type="line",
dashStyle="dash",
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste('<strong>{series.name}',
'</strong><br/>',sep=""),
pointFormat=paste('<strong>Threshold: ',
'</strong>{point.x}<br/>',sep="")
),
data=list(round(c(-fcut,ylim[1]-5),3),
round(c(-fcut,ylim[2]),3))
),
list(
name="Upfold threshold",
color="#000000",
type="line",
dashStyle="Dash",
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste('<strong>{series.name}',
'</strong><br/>',sep=""),
pointFormat=paste('<strong>Threshold: ',
'</strong>{point.x}<br/>',sep="")
),
data=list(round(c(fcut,ylim[1]-5),3),
round(c(fcut,ylim[2]),3))
),
list(
name="Significance threshold",
color="#000000",
type="line",
dashStyle="DashDot",
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste('<strong>{series.name}',
'</strong><br/>',sep=""),
pointFormat=paste('<strong>Threshold: ',
'</strong>{point.y}<br/>',sep="")
),
data=list(round(c(xlim[1],-log10(pcut)),3),
round(c(xlim[2],-log10(pcut)),3))
)
)
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out=="list")
return(json)
}
scatterToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- tolower(out[1])
x <- obj$x
y <- obj$y
altNames <- obj$altnames
type <- obj$user$covarname
status <- obj$status
samples <- obj$samples
if (type=="Mean-Difference") {
xLab <- "Mean"
yLab <- "Difference"
}
else if (type=="Mean-Variance") {
xLab <- "Mean"
yLab <- "Variance"
}
else if (type=="X-Y") {
xLab <- paste("Expression for",samples[1])
yLab <- paste("Expression for",samples[2])
}
# Too many points for mostly static, QC plots
if (length(x)>10000) {
ii <- sample(seq_len(length(x)),10000)
x <- x[ii]
y <- y[ii]
}
fit <- lowess(x,y)
stMsg <- ""
if (!is.null(status))
stMsg <- status
switch(jl,
highcharts = {
#if (is.null(altNames))
# point.format=paste("<strong>Gene ID: </strong>{point.name}<br>",
# "<strong>",xLab,": </strong>{point.x}<br>",
# "<strong>",yLab,": </strong>{point.y}",sep="")
#else
# point.format=paste("<strong>Gene name: </strong>",
# "{point.alt_name}<br>",
# "<strong>Gene ID: </strong>{point.name}<br>",
# "<strong>",xLab,": </strong>{point.x}<br>",
# "<strong>",yLab,": </strong>{point.y}",sep="")
point.format=paste("<strong>",xLab,": </strong>{point.x}<br>",
"<strong>",yLab,": </strong>{point.y}",sep="")
json <- list(
chart=list(
type="scatter",
zoomType="xy"
),
title=list(
text=paste(type,"plot for",stMsg,"samples",samples[1],
"and",samples[2])
),
xAxis=list(
title=list(
text=xLab,
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(min(x),3),
max=round(max(x),3)
),
yAxis=list(
title=list(
useHTML=TRUE,
text=yLab,
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(min(y),3),
max=round(max(y),3)
),
plotOptions=list(
scatter=list(
turboThreshold=25000
),
line=list(
turboThreshold=25000
)
),
series=list(
list(
type="scatter",
name="Genes/Transcripts",
#color="#00ABEE",
color="rgba(0,171,238,0.5)",
marker=list(
radius=0.5
),
#data=makeHighchartsPoints(x,y,unname(altNames)),
data=makeHighchartsPoints(x,y,simple=TRUE),
tooltip=list(
followPointer=FALSE,
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=point.format
)
),
list(
type="line",
name="Trend",
marker=list(
enabled=FALSE
),
color="#E40000",
data=lapply(seq_len(length(x)),function(i,x,y) {
return(c(x[i],y[i]))
},round(fit$x,3),round(fit$y,3))
)
)
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out=="list")
return(json)
}
rnacompToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- tolower(out[1])
status <- obj$status
dat <- obj$user$plotdata$data2plot
samples <- obj$samples
refColumn <- obj$user$plotdata$refColumn
# Too many points for a lot of curves of interactive data
if (nrow(dat)>1000) {
ii <- sort(sample(seq_len(nrow(dat)),998))
ii <- c(1,ii,nrow(dat))
dat <- cbind(dat[ii,1],dat[ii,2:ncol(dat)])
}
if (is.list(samples))
samplenames <- unlist(samples)
samplenames <- setdiff(samplenames,refColumn)
dat <- as.matrix(dat[,samplenames])
datDens <- apply(dat,2,density,adjust=1.5)
limY <- c(0,max(vapply(datDens,function (x) max(x$y,na.rm=TRUE),
numeric(1))))
cols <- .getColorScheme(length(samplenames))
# Construct series
counter <- 0
densSeries <- vector("list",length(samplenames))
names(densSeries) <- samplenames
for (n in names(densSeries)) {
counter <- counter + 1
densSeries[[n]] <- list()
densSeries[[n]]$name=n
densSeries[[n]]$color=cols$fill[counter]
densSeries[[n]]$data <-
makeHighchartsPoints(datDens[[n]]$x,datDens[[n]]$y)
densSeries[[n]]$tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=NULL
)
}
counter <- 0
abSeries <- vector("list",length(samplenames))
names(abSeries) <- samplenames
for (n in names(abSeries)) {
counter <- counter + 1
abSeries[[n]] <- list()
abSeries[[n]]$name=paste(n,"median")
abSeries[[n]]$color=cols$fill[counter]
abSeries[[n]]$data <-
makeHighchartsPoints(rep(median(dat[,n],na.rm=TRUE),nrow(dat)),
seq(limY[1],limY[2],length.out=nrow(dat)))
abSeries[[n]]$enableMouseTracking=FALSE
abSeries[[n]]$dashStyle="Dash"
}
switch(jl,
highcharts = {
json <- list(
chart=list(
type="line",
zoomType="xy"
),
title=list(
text=paste("RNA-composition for",status,"mapped reads")
),
xAxis=list(
title=list(
text="log<sub>2</sub>(sample/reference sample)",
margin=20,
useHTML=TRUE,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1
),
yAxis=list(
title=list(
text="Density",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=limY[1],
max=limY[2]
),
plotOptions=list(
line=list(
allowPointSelect=TRUE,
lineWidth=1,
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=NULL
),
turboThreshold=50000
)
),
series=c(unname(densSeries),unname(abSeries))
)
}
)
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out=="list")
return(json)
}
biodistToJSON <- function(obj,jl=c("highcharts"),by=c("chromosome","biotype"),
out=c("json","list")) {
jl <- tolower(jl[1])
by <- by[1]
out <- tolower(out[1])
plotdataChromosome <- obj$user$plotdata$chromosome
plotdataBiotype <- obj$user$plotdata$biotype
cols <- .getColorScheme()
if (by == "chromosome") {
# Data series
series <- vector("list",3)
names(series) <- c("genome","chromosome_deg","deg_chromosome")
series$genome <- list()
series$genome$id <- "genome"
series$genome$name <- "% chromosome in genome"
series$genome$color <- cols$trans[1]
series$genome$pointPlacement <- -0.2
series$genome$data <- round(as.numeric(plotdataChromosome[1,]),3)
series$chromosome_deg <- list()
series$chromosome_deg$id <- "chromosome_deg"
series$chromosome_deg$name <- "% chromosome in DEG"
series$chromosome_deg$color <- cols$trans[2]
series$chromosome_deg$pointPlacement <- 0
series$chromosome_deg$data <-
round(as.numeric(plotdataChromosome[2,]),3)
series$deg_chromosome <- list()
series$deg_chromosome$id <- "deg_chromosome"
series$deg_chromosome$name <- "% DEG in chromosome"
series$deg_chromosome$color <- cols$trans[3]
series$deg_chromosome$pointPlacement <- 0.2
series$deg_chromosome$data <-
round(as.numeric(plotdataChromosome[3,]),3)
json <- switch(jl,
highcharts = {
list(
chart=list(
type="column",
alignTicks=FALSE
),
title=list(
text="DEG distribution across chromosomes"
),
legend=list(
enabled=TRUE,
itemHoverStyle=list(
color="#B40000"
)
),
tooltip=list(
shared=TRUE
),
xAxis=list(
categories=names(plotdataChromosome),
title=list(
text="Chromosome",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
)
),
yAxis=list(
list(
min=0,
max=ceiling(max(plotdataChromosome[1,])),
title=list(
text="% of features",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
)
)
),
plotOptions=list(
column=list(
grouping=FALSE,
shadow=FALSE,
groupPadding=0.3,
pointPadding=0.25,
tooltip=list(
headerFormat=paste(
'<span style="font-size:1.1em;',
'font-weight:bold">',
'{point.key}</span><br/>',sep=""
)
)
)
),
series=unname(series)
)
}
)
}
if (by == "biotype") {
# For biotype
abu <- which(plotdataBiotype[1,]>7)
nabu <- which(plotdataBiotype[1,]<=7)
# Data series
seriesAbu <- vector("list",3)
names(seriesAbu) <- c("genome","biotype_deg","deg_biotype")
seriesAbu$genome <- list()
seriesAbu$genome$id <- "abu_genome"
seriesAbu$genome$name <- "% biotype in genome"
seriesAbu$genome$color <- cols$trans[1]
seriesAbu$genome$pointPlacement <- -0.2
seriesAbu$genome$data <- round(as.numeric(plotdataBiotype[1,abu]),3)
seriesAbu$biotype_deg <- list()
seriesAbu$biotype_deg$id <- "abu_biotype_deg"
seriesAbu$biotype_deg$name <- "% biotype in DEG"
seriesAbu$biotype_deg$color <- cols$trans[2]
seriesAbu$biotype_deg$pointPlacement <- 0
seriesAbu$biotype_deg$data <-
round(as.numeric(plotdataBiotype[2,abu]),3)
seriesAbu$deg_biotype <- list()
seriesAbu$deg_biotype$id <- "abu_deg_biotype"
seriesAbu$deg_biotype$name <- "% DEG in biotype"
seriesAbu$deg_biotype$color <- cols$trans[3]
seriesAbu$deg_biotype$pointPlacement <- 0.2
seriesAbu$deg_biotype$data <-
round(as.numeric(plotdataBiotype[3,abu]),3)
seriesNabu <- vector("list",3)
names(seriesNabu) <- c("genome","biotype_deg","deg_biotype")
seriesNabu$genome <- list()
seriesNabu$genome$name <- "% biotype in genome"
seriesNabu$genome$yAxis <- 1
seriesNabu$genome$pointStart <- length(abu)
seriesNabu$genome$linkedTo <- "abu_genome"
seriesNabu$genome$color <- cols$trans[1]
seriesNabu$genome$pointPlacement <- -0.2
seriesNabu$genome$data <- round(as.numeric(plotdataBiotype[1,nabu]),3)
seriesNabu$biotype_deg <- list()
seriesNabu$biotype_deg$name <- "% biotype in DEG"
seriesNabu$biotype_deg$yAxis <- 1
seriesNabu$biotype_deg$pointStart <- length(abu)
seriesNabu$biotype_deg$linkedTo <- "abu_detected"
seriesNabu$biotype_deg$color <- cols$trans[2]
seriesNabu$biotype_deg$pointPlacement <- 0
seriesNabu$biotype_deg$data <-
round(as.numeric(plotdataBiotype[2,nabu]),3)
seriesNabu$deg_biotype <- list()
seriesNabu$deg_biotype$name <- "% DEG in biotype"
seriesNabu$deg_biotype$yAxis <- 1
seriesNabu$deg_biotype$pointStart <- length(abu)
seriesNabu$deg_biotype$linkedTo <- "abu_sample"
seriesNabu$deg_biotype$color <- cols$trans[3]
seriesNabu$deg_biotype$pointPlacement <- 0.2
seriesNabu$deg_biotype$data <-
round(as.numeric(plotdataBiotype[3,nabu]),3)
json <- switch(jl,
highcharts = {
list(
chart=list(
type="column",
alignTicks=FALSE
),
title=list(
text="DEG distribution across biotypes"
),
legend=list(
enabled=TRUE,
itemHoverStyle=list(
color="#B40000"
)
),
tooltip=list(
shared=TRUE
),
xAxis=list(
categories=colnames(plotdataBiotype)[c(abu,nabu)],
title=list(
text="Biotype",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontWeight="bold"
)
),
plotLines=list(
list(
color="#8A8A8A",
width=1.5,
dashStyle="Dash",
value=length(abu)-0.5
)
),
plotBands=list(
list(
color="#FFFFE0",
from=-0.5,
to=length(abu)-0.5
),
list(
color="#FFECEB",
from=length(abu)-0.5,
to=ncol(plotdataBiotype)
)
)
),
yAxis=list(
list(
min=0,
max=70,
title=list(
text="% of abundant features",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
)
),
list(
min=0,
max=7,
title=list(
text="% of non-abundant features",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
opposite=TRUE
)
),
plotOptions=list(
column=list(
grouping=FALSE,
shadow=FALSE,
groupPadding=0.3,
pointPadding=0.25,
tooltip=list(
headerFormat=paste(
'<span style="font-size:1.1em;',
'font-weight:bold">',
'{point.key}</span><br/>',sep=""
)
)
)
),
series=c(unname(seriesAbu),unname(seriesNabu))
)
}
)
}
if (out=="json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out=="list")
return(json)
}
maStatToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- out[1]
a <- obj$x
f <- obj$y
p <- obj$user$p
xlim <- obj$xlim
ylim <- obj$ylim
pcut <- obj$pcut
fcut <- obj$fcut
altNames <- obj$altnames
con <- obj$user$con
#stat <- obj$user$stat
conlab <- strsplit(con,"_vs_")
conlab <- paste(conlab[[1]][1],"against",conlab[[1]][2])
#conlab <- paste(conlab[[1]][2],"against",conlab[[1]][1])
#statMap <- .getStatMap()
#statlab <- statMap[[stat]]
if (!is.null(p)) {
upstat <- which(f>=fcut & p<pcut)
downstat <- which(f<=-fcut & p<pcut)
up <- which(f>=fcut & p>=pcut)
down <- which(f<=-fcut & p>=pcut)
poor <- which(p<pcut & abs(f)<fcut)
neutral <- setdiff(seq_len(length(a)),
Reduce("union",list(upstat,downstat,up,down,poor)))
}
else {
upstat <- downstat <- poor <- integer(0)
up <- which(f>=fcut)
down <- which(f<=-fcut)
neutral <- setdiff(seq_len(length(a)),union(up,down))
}
switch(jl,
highcharts = {
series <- list()
counter <- 0
if (length(upstat)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significantly up-regulated",
color="#EE0000",
marker=list(
radius=3
),
data=makeHighchartsPoints(
x=a[upstat],
y=f[upstat],
a=unname(altNames[upstat]),
p=if (!is.null(p)) -log10(p[upstat]) else NULL
)
)
}
if (length(downstat)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significantly down-regulated",
color="#00EE00",
marker=list(
radius=3
),
data=makeHighchartsPoints(
x=a[downstat],
y=f[downstat],
a=unname(altNames[downstat]),
p=if (!is.null(p)) -log10(p[downstat]) else NULL
)
)
}
if (length(up)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Up-regulated",
color="#B80000",
marker=list(
radius=2
),
data=makeHighchartsPoints(
x=a[up],
y=f[up],
a=unname(altNames[up]),
p=if (!is.null(p)) -log10(p[up]) else NULL
)
)
}
if (length(down)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Down-regulated",
color="#008000",
marker=list(
radius=2
),
data=makeHighchartsPoints(
x=a[down],
y=f[down],
a=unname(altNames[down]),
p=if (!is.null(p)) -log10(p[down]) else NULL
)
)
}
if (length(poor)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significant only",
color="#FFA600",
data=makeHighchartsPoints(
x=a[poor],
y=f[poor],
a=unname(altNames[poor]),
p=if (!is.null(p)) -log10(p[poor]) else NULL
)
)
}
if (length(neutral)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Neutral",
color="#858585",
data=makeHighchartsPoints(
x=a[neutral],
y=f[neutral],
a=unname(altNames[neutral]),
p=if (!is.null(p)) -log10(p[neutral]) else NULL
)
)
}
if (is.null(altNames))
point.format=paste("<strong>Gene ID: </strong>{point.name}<br>",
"<strong>Average expression: </strong>{point.x}<br>",
"<strong>Fold change: </strong>{point.y}<br>",
"<strong>Significance: </strong>{point.sig}",sep="")
else
point.format=paste("<strong>Gene name: </strong>",
"{point.alt_name}<br>",
"<strong>Gene ID: </strong>{point.name}<br>",
"<strong>Average expression: </strong>{point.x}<br>",
"<strong>Fold change: </strong>{point.y}<br>",
"<strong>Significance: </strong>{point.sig}",sep="")
json <- list(
chart=list(
type="scatter",
zoomType="xy"
),
title=list(
text=paste("Mean-Difference (MA) plot for",conlab)
),
xAxis=list(
title=list(
text="Average expression",
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(xlim[1],3),
max=round(xlim[2],3)
),
yAxis=list(
title=list(
useHTML=TRUE,
text="Fold change (log<sub>2</sub>)",
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(ylim[1],3),
max=round(ylim[2],3)
),
plotOptions=list(
scatter=list(
allowPointSelect=TRUE,
marker=list(
radius=2,
symbol="circle",
states=list(
hover=list(
enabled=TRUE,
lineColor="#333333"
)
)
),
states=list(
hover=list(
marker=list(
enabled=FALSE
)
)
),
#events=list(
# legendItemClick=paste("function() {",
# "return false; }")
#),
tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=point.format
),
turboThreshold=50000
)
),
series=series
)
}
)
if (out == "json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out == "list")
return(json)
}
dereguloToJSON <- function(obj,jl=c("highcharts"),out=c("json","list")) {
jl <- tolower(jl[1])
out <- out[1]
xlim <- obj$xlim
ylim <- obj$ylim
pcut <- obj$pcut
fcut <- obj$fcut
altNames <- obj$altnames
fmat <- obj$user$fmat
pmat <- obj$user$pmat
conlabX <- strsplit(colnames(fmat)[1],"_vs_")
conlabX <- paste(conlabX[[1]][1],"against",conlabX[[1]][2])
conlabY <- strsplit(colnames(fmat)[2],"_vs_")
conlabY <- paste(conlabY[[1]][1],"against",conlabY[[1]][2])
# red
upupstat <- which(apply(fmat,1,function(x) all(x >= fcut)) &
apply(pmat,1,function(x) all(x < pcut)))
# green
downdownstat <- which(apply(fmat,1,function(x) all(x <= -fcut)) &
apply(pmat,1,function(x) all(x < pcut)))
# red3
upup <- which(apply(fmat,1,function(x) all(x >= fcut)) &
apply(pmat,1,function(x) any(x >= pcut)))
# green3
downdown <- which(apply(fmat,1,function(x) all(x <= -fcut)) &
apply(pmat,1,function(x) any(x >= pcut)))
# orange
updownstat <- which(apply(fmat,1,
function(x) x[1] >= fcut & x[2] <= -fcut) &
apply(pmat,1,function(x) all(x < pcut)))
# blue
downupstat <- which(apply(fmat,1,
function(x) x[1] <= -fcut & x[2] >= fcut) &
apply(pmat,1,function(x) all(x < pcut)))
# orange3
updown <- which(apply(fmat,1,function(x) x[1] >= fcut & x[2] <= -fcut) &
apply(pmat,1,function(x) any(x >= pcut)))
# blue3
downup <- which(apply(fmat,1,function(x) x[1] <= -fcut & x[2] >= fcut) &
apply(pmat,1,function(x) any(x >= pcut)))
# black
poor <- which(apply(pmat,1,function(x) all(x < pcut)) &
apply(fmat,1,function(x) any(abs(x) < fcut)))
# gray70
nones <- which(apply(pmat,1,function(x) any(x >= pcut)) &
apply(fmat,1,function(x) all(abs(x) < fcut)))
# gray40
neutral <- setdiff(seq_len(nrow(fmat)),
Reduce("union",list(upupstat,downdownstat,upup,downdown,updownstat,
downupstat,updown,downup,poor,nones)))
switch(jl,
highcharts = {
series <- list()
counter <- 0
if (length(upupstat)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significantly both up-regulated",
color="#EE0000",
marker=list(
radius=3
),
data=makeHighchartsPoints(
x=fmat[upupstat,1],
y=fmat[upupstat,2],
a=unname(altNames[upupstat])
)
)
}
if (length(downdownstat)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significantly both down-regulated",
color="#00EE00",
marker=list(
radius=3
),
data=makeHighchartsPoints(
x=fmat[downdownstat,1],
y=fmat[downdownstat,2],
a=unname(altNames[downdownstat])
)
)
}
if (length(upup)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Both up-regulated",
color="#B80000",
marker=list(
radius=2
),
data=makeHighchartsPoints(
x=fmat[upup,1],
y=fmat[upup,2],
a=unname(altNames[upup])
)
)
}
if (length(downdown)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Both down-regulated",
color="#008000",
marker=list(
radius=2
),
data=makeHighchartsPoints(
x=fmat[downdown,1],
y=fmat[downdown,2],
a=unname(altNames[downdown])
)
)
}
if (length(updownstat)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significantly up-down-regulated",
color="#FFB700",
marker=list(
radius=3
),
data=makeHighchartsPoints(
x=fmat[updownstat,1],
y=fmat[updownstat,2],
a=unname(altNames[updownstat])
)
)
}
if (length(downupstat)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significantly down-up-regulated",
color="#0000FF",
marker=list(
radius=3
),
data=makeHighchartsPoints(
x=fmat[downupstat,1],
y=fmat[downupstat,2],
a=unname(altNames[downupstat])
)
)
}
if (length(updown)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Up-down-regulated",
color="#C68100",
marker=list(
radius=2
),
data=makeHighchartsPoints(
x=fmat[updown,1],
y=fmat[updown,2],
a=unname(altNames[updown])
)
)
}
if (length(downup)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Down-up-regulated",
color="#0000AB",
marker=list(
radius=2
),
data=makeHighchartsPoints(
x=fmat[downup,1],
y=fmat[downup,2],
a=unname(altNames[downup])
)
)
}
if (length(poor)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Significant only",
color="#1F1F1F",
data=makeHighchartsPoints(
x=fmat[poor,1],
y=fmat[poor,2],
a=unname(altNames[poor])
)
)
}
if (length(neutral)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="Neutral",
color="#00DADE",
data=makeHighchartsPoints(
x=fmat[neutral,1],
y=fmat[neutral,2],
a=unname(altNames[neutral])
)
)
}
if (length(nones)>0) {
counter <- counter + 1
series[[counter]] <- list(
name="No regulation",
color="#CCCCCC",
data=makeHighchartsPoints(
x=fmat[nones,1],
y=fmat[nones,2],
a=unname(altNames[nones])
)
)
}
# Add fold lines
counter <- counter + 1
series[[counter]] <- list(
name="X up fold threshold",
color="#000000",
type="line",
dashStyle="Dash",
lineWidth=1,
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste('<strong>{series.name}',
'</strong><br/>',sep=""),
pointFormat=paste('<strong>Threshold: ',
'</strong>{point.x}<br/>',sep="")
),
data=list(round(c(fcut,floor(ylim[1])),3),
round(c(fcut,ceiling(ylim[2])),3))
)
counter <- counter + 1
series[[counter]] <- list(
name="X down fold threshold",
color="#000000",
type="line",
dashStyle="Dash",
lineWidth=1,
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste('<strong>{series.name}',
'</strong><br/>',sep=""),
pointFormat=paste('<strong>Threshold: ',
'</strong>{point.x}<br/>',sep="")
),
data=list(round(c(-fcut,floor(ylim[1])),3),
round(c(-fcut,ceiling(ylim[2])),3))
)
counter <- counter + 1
series[[counter]] <- list(
name="Y up fold threshold",
color="#000000",
type="line",
dashStyle="Dash",
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste('<strong>{series.name}',
'</strong><br/>',sep=""),
pointFormat=paste('<strong>Threshold: ',
'</strong>{point.y}<br/>',sep="")
),
data=list(round(c(floor(xlim[1]),fcut),3),
round(c(ceiling(xlim[2]),fcut),3))
)
counter <- counter + 1
series[[counter]] <- list(
name="Y down fold threshold",
color="#000000",
type="line",
dashStyle="Dash",
marker=list(
enabled=FALSE
),
tooltip=list(
headerFormat=paste('<strong>{series.name}',
'</strong><br/>',sep=""),
pointFormat=paste('<strong>Threshold: ',
'</strong>{point.y}<br/>',sep="")
),
data=list(round(c(floor(xlim[1]),-fcut),3),
round(c(ceiling(xlim[2]),-fcut),3))
)
if (is.null(altNames))
point.format=paste("<strong>Gene ID: </strong>{point.name}<br>",
"<strong>Fold change X: </strong>{point.x}<br>",
"<strong>Fold change Y: </strong>{point.y}<br>",sep="")
else
point.format=paste("<strong>Gene name: </strong>",
"{point.alt_name}<br>",
"<strong>Gene ID: </strong>{point.name}<br>",
"<strong>Fold change X: </strong>{point.x}<br>",
"<strong>Fold change Y: </strong>{point.y}<br>",sep="")
json <- list(
chart=list(
type="scatter",
zoomType="xy"
),
title=list(
text=paste("Deregulogram")
),
xAxis=list(
title=list(
text=paste0("Fold change (log<sub>2</sub>)",conlabX),
margin=20,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(xlim[1],3),
max=round(xlim[2],3)
),
yAxis=list(
title=list(
useHTML=TRUE,
text=paste0("Fold change (log<sub>2</sub>)",conlabY),
margin=25,
style=list(
color="#000000",
fontSize="1.2em"
)
),
labels=list(
style=list(
color="#000000",
fontSize="1.1em",
fontWeight="bold"
)
),
startOnTick=TRUE,
endOnTick=TRUE,
showLastLabel=TRUE,
gridLineWidth=1,
min=round(ylim[1],3),
max=round(ylim[2],3)
),
plotOptions=list(
scatter=list(
allowPointSelect=TRUE,
marker=list(
radius=2,
symbol="circle",
states=list(
hover=list(
enabled=TRUE,
lineColor="#333333"
)
)
),
states=list(
hover=list(
marker=list(
enabled=FALSE
)
)
),
tooltip=list(
headerFormat=paste("<span style=",
"\"font-size:1.1em;color:{series.color};",
"font-weight:bold\">{series.name}<br>",
sep=""),
pointFormat=point.format
),
turboThreshold=50000
)
),
series=series
)
}
)
if (out == "json")
return(toJSON(json,auto_unbox=TRUE,null="null"))
else if (out == "list")
return(json)
}
.unquote_js_fun <- function(js) {
if (is.list(js))
js <- lapply(js,.unquote_js_fun)
else {
op <- gregexpr(pattern="function",js)
cl <- gregexpr(pattern="}\\\"",js)
if (length(op)>0) {
starts <- as.numeric(op[[1]])
for (i in seq_len(length(starts)))
substr(js,starts[i]-1,starts[i]-1) <- " "
ends <- as.numeric(cl[[1]])
for (i in seq_len(length(starts)))
substr(js,ends[i]+1,ends[i]+1) <- " "
}
}
return(js)
}
.getGroupColorScheme <- function(group) {
cols <- .getColorScheme(length(group))
classes <- as.factor(asClassVector(group))
design <- as.numeric(classes)
return(lapply(cols,function(x,classes,design) {
return(x[seq_len(length(levels(classes)))][design])
},classes,design))
}
.getColorScheme <- function(n=NULL) {
if (missing(n) || is.null(n))
return(.getColors())
else {
cols <- .getColors()
if (n > length(cols$fill)) {
cols$fill <- rep(cols$fill,length.out=n)
cols$border <- rep(cols$border,length.out=n)
cols$select <- rep(cols$select,length.out=n)
cols$trans <- rep(cols$trans,length.out=n)
}
return(cols)
}
}
.getColors <- function() {
return(list(
fill=c("#CD0000","#00CD00","#0000EE","#FFD700","#87CEEB","#CD8500",
"#DEB887","#FF0000","#0000FF","#00FF00","#FFA500","#A9A9A9",
"#008B00","#313131","#FFC0CB","#A52A2A","#FF00FF","#9ACD32",
"#8B636C","#2E8B57","#008B8B"),
border=c("#850000","#006B00","#000085","#927C00","#156280","#5A3A00",
"#8B7457","#935E18","#000080","#008500","#603E00","#454545",
"#073E07","#000000","#896067","#691111","#7C007C","#3A4D14",
"#5B1726","#0C2517","#062A2A"),
selected=c("#FF0000","#00FF00","#0066FF","#FFD700","#FFEB77","#FFB428",
"#FFD9A5","#FF326D","#0089FF","#B3FF00","#FFC352","#D9D9D9",
"#00EC00","#8E8E8E","#FFDAE0","#F94444","#FF87FF","#C2FF45",
"#EA889D","#4EE590","#00DADA"),
trans=c("rgba(205,0,0,0.6)","rgba(0,205,0,0.6)","rgba(0,0,238,0.6)",
"rgba(255,215,0,0.6)","rgba(135,206,235,0.6)","rgba(205,133,0,0.6)",
"rgba(222,184,135,0.6)","rbga(255,0,0,0.5)","rgba(0,0,255,0.5)",
"rgba(0,255,0,0.5)","rgba(255,165,0,0.6)","rgba(169,169,169,0.5)",
"rgba(0,139,0,0.6)","rgba(49,49,49,0.6)","rgba(255,192,203,0.5)",
"rgba(165,42,42,0.6)","rgba(255,0,255,0.6)","rgba(154,205,50,0.6)",
"rgba(139,99,108,0.6)","rgba(46,139,87,0.6)","rgba(0,139,139,0.6)")
))
}
.getStatMap <- function() {
return(list(
deseq="DEseq",
deseq2="DEseq2",
edger="edgeR",
limma="voom",
nbpseq="NBPSeq",
noiseq="NOISeq",
#bayseq="baySeq",
absseq="ABSSeq",
dss="DSS"
))
}
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.