R functions for creating interactive heatmap using Plotly (now packages exist to do this)

active_heatmap.R

# install.packages(c("plotly", "reshape2", "ggdendro"))
# devtools::install_github("sjmgarnier/viridis")
library(ggplot2)
library(ggdendro)
library(plotly)
library(viridis)


# helper function for creating dendograms
ggdend <- function(df) {
    ggplot() +
        geom_segment(data = df, aes(x=x, y=y, xend=xend, yend=yend)) +
        labs(x = "", y = "") + theme_minimal() +
        theme(axis.text = element_blank(), axis.ticks = element_blank(),
              panel.grid = element_blank())
}

# function to subset dataframe by a group variable
facet_subset <- function(df, colname) {
    facets = list()
    for (facet in unique(df[,colname])) {
        facets[[facet]] = subset(df, df[,colname] == facet)
        facets[[facet]]$set <- NULL
    }
    return(facets)
}

# function to make the panel
make_active_panel <- function(facets, num_rows=2, row_clust=TRUE, 
                              col_clust=TRUE, margin=0.01, 
                              rel_heights=c(0.2, 0.7), 
                              rel_widths=c(0.7, 0.2)) {
    p_list = list()
    for (facet in names(facets)) {
        #print(facets[[facet]])
        #facet="set_1"
        
        if (col_clust == TRUE) {
            dd.row <- as.dendrogram(hclust(dist(t(facets[[facet]]))))
            dx <- dendro_data(dd.row)
            px <- ggdend(dx$segments)
            row.ord <- order.dendrogram(dd.row)
            sub <- facets[[facet]][, row.ord]
        } else {
            sub <- facets[[facet]]
        }
        if (row_clust == TRUE) {
            dd.col <- as.dendrogram(hclust(dist(facets[[facet]])))
            dy <- dendro_data(dd.col)
            py <- ggdend(dy$segments) + coord_flip()
            col.ord <- order.dendrogram(dd.col)
            sub <- sub[col.ord, ]
        } else {
            sub <- sub
        }
        
        sub$gene <- with(sub, factor(row.names(sub), levels=row.names(sub), 
                                     ordered=TRUE))
        mdf <- reshape2::melt(sub, id.vars="gene", value.name="expression")
        p <- ggplot(mdf, aes(x=variable, y=gene)) + 
            geom_tile(aes(fill=expression)) +
            theme_minimal() + 
            theme(axis.text.y=element_blank(),
                  axis.title.y=element_text(facet)) +
            scale_fill_viridis(limits=c(min(unlist(lapply(facets,FUN=min))),
                                        max(unlist(lapply(facets,FUN=max)))))
        
        eaxis <- list(
            showticklabels = FALSE,
            showgrid = FALSE,
            zeroline = FALSE
        )
        
        p_empty <- plot_ly(mode="markers", type="scatter") %>%
            # note that margin applies to entire plot, so we can
            # add it here to make tick labels more readable
            layout(margin = list(l = 200),
                   xaxis = eaxis,
                   yaxis = eaxis)
        
        if (row_clust == TRUE) {
            if (col_clust == TRUE) {
                p_list[[facet]] <- subplot(px, p_empty, p, py, nrows = 2, 
                                           margin = margin, heights=rel_heights, 
                                           widths=rel_widths)
            } else {
                p_list[[facet]] <- subplot(p, py, nrows = 1, 
                                           margin = margin, widths=rel_widths)
            }
        } else {
            if (col_clust == TRUE) {
                p_list[[facet]] <- subplot(px, p, nrows = 2, 
                                           margin = margin, heights=rel_heights)
            } else {
                p_list[[facet]] <- p
            }
        }
        
        # p_list[[facet]] <- subplot(px, p_empty, p, py, nrows = 2, margin = 0.01, 
        #                            heights=c(0.2, 0.6), widths=c(0.6, 0.2))
    }
    
    return(subplot(p_list, nrows=num_rows))
}

# function to make the plot
make_active_plot <- function(df, row_clust=TRUE, col_clust=TRUE, 
                              scale=FALSE, margin=0.01, 
                              rel_heights=c(0.2, 0.7), 
                              rel_widths=c(0.7, 0.2)) {

    if (col_clust == TRUE) {
        dd.row <- as.dendrogram(hclust(dist(t(df))))
        dx <- dendro_data(dd.row)
        px <- ggdend(dx$segments)
        row.ord <- order.dendrogram(dd.row)
        sub <- df[, row.ord]
    } else {
        sub <- df
    }
    if (row_clust == TRUE) {
        dd.col <- as.dendrogram(hclust(dist(df)))
        dy <- dendro_data(dd.col)
        py <- ggdend(dy$segments) + coord_flip()
        col.ord <- order.dendrogram(dd.col)
        sub <- sub[col.ord, ]
    } else {
        sub <- sub
    }
    
    if (scale == TRUE) {
        xx <- scale(sub)
        xx_names <- attr(xx, "dimnames")
        sub_scale <- as.data.frame(xx)
        colnames(sub_scale) <- xx_names[[2]]
        row.names(sub_scale) <- xx_names[[1]]
        sub <- sub_scale
    }
    
    print(sub)
    
    sub$gene <- with(sub, factor(row.names(sub), levels=row.names(sub), 
                                 ordered=TRUE))
    mdf <- reshape2::melt(sub, id.vars="gene", value.name="expression")
    p <- ggplot(mdf, aes(x=variable, y=gene)) + 
        geom_tile(aes(fill=expression)) +
        theme_minimal() + 
        theme(axis.text.y=element_blank()) +
        scale_fill_viridis()
    
    eaxis <- list(
        showticklabels = FALSE,
        showgrid = FALSE,
        zeroline = FALSE
    )
        
    p_empty <- plot_ly(mode="markers", type="scatter") %>%
        # note that margin applies to entire plot, so we can
        # add it here to make tick labels more readable
        layout(margin = list(l = 200),
               xaxis = eaxis,
               yaxis = eaxis)
    
    if (row_clust == TRUE) {
        if (col_clust == TRUE) {
            plt <- subplot(px, p_empty, p, py, nrows = 2, 
                                       margin = margin, heights=rel_heights, 
                                       widths=rel_widths)
        } else {
            plt <- subplot(p, py, nrows = 1, 
                                       margin = margin, widths=rel_widths)
        }
    } else {
        if (col_clust == TRUE) {
            plt <- subplot(px, p, nrows = 2, 
                                       margin = margin, heights=rel_heights)
        } else {
            plt <- p
        }
    }
    
    return(plt)
}
   

# main function for creating an active panel
active_panel <- function(df, colname, num_rows=2, row_clust=TRUE, 
                         col_clust=TRUE, margin=0.01, 
                         rel_heights=c(0.2, 0.7), rel_widths=c(0.7, 0.2)) {
    
    facet_list <- facet_subset(df, colname);
    
    panel <- make_active_panel(facets=facet_list, num_rows=num_rows, 
                               row_clust=row_clust, col_clust=col_clust, 
                               margin=margin, rel_heights=rel_heights, 
                               rel_widths=rel_widths)
    
    return(panel)
    
}


# main function for creating an active plot
active_plot <- function(df, row_clust=TRUE, col_clust=TRUE, 
                        scale=FALSE, margin=0.01, 
                        rel_heights=c(0.2, 0.7), rel_widths=c(0.7, 0.2)) {
    
    plt <- make_active_plot(df, row_clust=row_clust, col_clust=col_clust, 
                               scale=scale, margin=margin, 
                               rel_heights=rel_heights, rel_widths=rel_widths)
    
    return(plt)
    
}