Alternative version of ASSIGN heatmap plot

assign.R

require(Biobase)
require(RColorBrewer)
require(plotly)

# Fake Data
set.seed(124)
samples = paste("S", (1:50), sep="")
genes = paste("G", (1:200), sep="")
row_hist1 = runif(50, min=0, max=1)
row_hist2 = runif(50, min=0.9, max=1)
col_hist1 = rnorm(200)
col.df = data.frame(list(col_hist1=col_hist1))
col.df$genes = genes
row.df = data.frame(list(row_hist1=row_hist1, row_hist2=row_hist2))
row.df$samples = samples
m = matrix(rexp(10000, rate=.1), ncol=50)
m = t(apply(m, 1, function(x) x/sum(x)))
m = as.data.frame(m)
colnames(m) = samples
rownames(m) = genes
sidecols = rep(c("Basal", "Normal", "Her2", "LumA", "LumB"), 10)

# Order gene and samples accordingly in each plot
m.sorted = m[order(col.df$col_hist1),order(-row.df$row_hist1)]
col.df.sorted <- col.df[order(col.df$col_hist1),]
row.df.sorted <- row.df[order(-row.df$row_hist1),]
sidecols.sorted <- sidecols[order(-row.df$row_hist1)]

print(table(col.df.sorted$genes == rownames(m.sorted)))
print(table(row.df.sorted$samples == colnames(m.sorted)))

# Color bar
sidenums = as.numeric(as.factor(sidecols.sorted))
hm.small <- plot_ly(z=t(data.matrix(sidenums)), 
                    type="heatmap",
                    hoverinfo="text",
                    text=t(sidecols.sorted),
                    showscale=F) %>%
  layout(xaxis = list(showticklabels=F, ticks=""),
         yaxis = list(showticklabels=F, ticks=""),
         margin = list(b=0,t=0,r=0,l=0))

# Expression heatmap
m.dmx <- data.matrix(m.sorted)
m.dmx.log <- log2(m.dmx+1)
m.dmx.log.scaled <- t(apply(m.dmx.log, 1, function(z) scale(z))) 
m.input <- m.dmx.log.scaled
palette <- colorRampPalette(c("blue", "white", "red"))
hm.big <- plot_ly(x = colnames(m.input), 
                  y = rownames(m.input), 
                  z = m.input, 
                  zmin=-3,
                  zmax=3,
                  colors = palette(50),
                  hoverinfo="x+y+z",
                  type = "heatmap",
                  showlegend=F,
                  showscale=F) %>%
          layout(xaxis = list(showticklabels=F, ticks=""),
                 yaxis = list(showticklabels=F, ticks=""),
                 margin = list(b=20,t=0,r=0,l=0))

# Barplots
ax.base = list(title="",
               categoryorder="trace",
               showticklabels=F, 
               showgrid=F, 
               zeroline=F, 
               showline=F,
               fixedrange=T)

# Sample Activity Scores
ax.y = ax.base
ax.y$title="Activity Score"
ax.y$titlefont=list(size="12")
bars.top <- plot_ly() %>%
  add_bars(y=row.df.sorted$row_hist2, 
           x=row.df.sorted$samples,
           hoverinfo="text+x",
           text=row.df.sorted$row_hist2,
           marker = list(color = '#BFBFBF')) %>%
  add_bars(y = row.df.sorted$row_hist1, 
           x=row.df.sorted$samples,
           hoverinfo="text+x",
           text=row.df.sorted$row_hist1,
           marker = list(color = '#23395B')) %>%
  layout(yaxis=ax.y,
         xaxis=ax.base,
         bargap=0,
         margin=list(b=10,t=0,r=0,l=30),
         showlegend = F,
         barmode = "overlay")

# Gene Activity Scores
genes.pos = length(which(col.df.sorted$col_hist1 < 0))
genes.neg = length(which(col.df.sorted$col_hist1 >= 0))
genes.col = c(rep('#BFBFBF', genes.pos), rep('#8CBA80', genes.neg))
temp.col.df <- data.frame(col.df.sorted)
which.neg = col.df.sorted$col_hist1 < 0
temp.col.df$col_hist1[which.neg] <- temp.col.df$col_hist1[which.neg]*-1
temp.col.df$col_hist1 = temp.col.df$col_hist1*-1 #temporary
ax.y = ax.base
ax.y$title="Gene Activity"
bars.left <- plot_ly(data=temp.col.df, 
                     y=~genes, 
                     x=~col_hist1,
                     hoverinfo="text+y",
                     text=col.df.sorted$col_hist1,
                     marker=list(color=genes.col),
                     type="bar") %>% 
  layout(xaxis=ax.base,
         yaxis=ax.y,
         bargap=0,
         showlegend=F,
         margin=list(b=10,t=0,r=0,l=0))

# Subplotting
empty <- plotly_empty(type = "scatter")

r.b <- subplot(hm.small,hm.big, titleY = TRUE, titleX = TRUE,
               nrows = 2, heights=c(0.05, 0.95),
               margin = 0.005) %>%
  layout(showlegend = FALSE)

l.b <- subplot(empty, bars.left, titleY = TRUE, titleX = TRUE,
               nrows = 2, heights=c(0.05, 0.95),
               margin = 0.005) %>%
  layout(showlegend = FALSE)

bottom <- subplot(l.b, r.b, titleY = TRUE, titleX = TRUE,
                  widths=c(0.25,  0.75),
                  margin = 0.01) %>%
  layout(showlegend = FALSE)

top <- subplot(empty, bars.top, titleY = TRUE, titleX = TRUE,
               widths=c(0.25,  0.75),
               margin = 0.01) %>%
  layout(showlegend = FALSE)

multi.plot <- subplot(top, bottom, titleY = TRUE, titleX = TRUE,
                      nrows = 2, heights=c(0.15, 0.85),
                      margin = 0.005) %>%
  layout(showlegend = FALSE) %>% 
  config(displayModeBar = F)

multi.plot