diff --git a/.gitignore b/.gitignore index 54fb7f9..e40ca94 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,5 @@ .Rhistory .RData TODO.txt +lib +*.html diff --git a/.travis.yml b/.travis.yml index ff1ac67..3f1d783 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,7 +3,7 @@ sudo: required warnings_are_errors: true after_success: - - Rscript -e 'covr::codecov()' + - Rscript -e 'library(covr); codecov()' r_github_packages: - hadley/testthat # for skip_if_not_installed diff --git a/DESCRIPTION b/DESCRIPTION index e67d166..7feefa4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -8,20 +8,22 @@ Authors@R: c(person("Tal", "Galili", role = c("aut", "cre", "cph"), email = person("Jonathan", "Sidi", email = "yonis@metrumrg.com", comment = "https://github.com/yonicd",role = "ctb"), person("Alan", "O'Callaghan", comment = "https://github.com/Alanocallaghan",role = "ctb"), person("Yoav", "Benjamini", email = "ybenja@tau.ac.il",role = "ths")) -Description: Create interactive cluster 'heatmaps' that can be saved as a stand-alone HTML - file, embedded in 'R Markdown' documents or in a 'Shiny' apps, and available in the 'RStudio' viewer pane, . - Hover the mouse pointer over a cell to show details or drag a rectangle to - zoom. A 'heatmap' is a popular graphical method for visualizing high-dimensional - data, in which a table of numbers are encoded as a grid of colored cells. The - rows and columns of the matrix are ordered to highlight patterns and are often - accompanied by 'dendrograms'. 'Heatmaps' are used in many fields for visualizing - observations, correlations, missing values patterns, and more. Interactive - 'heatmaps' allow the inspection of specific value by hovering the mouse over a - cell, as well as zooming into a region of the 'heatmap' by dragging a rectangle - around the relevant area. This work is based on the 'ggplot2' and 'plotly.js' - engine. It produces similar 'heatmaps' as 'heatmap.2' or 'd3heatmap', with the advantage of speed - ('plotly.js' is able to handle larger size matrix), the ability to zoom from the 'dendrogram' panes, - and the placing of factor variables in the sides of the 'heatmap'. +Description: Create interactive cluster 'heatmaps' that can be saved as a stand- + alone HTML file, embedded in 'R Markdown' documents or in a 'Shiny' apps, and + available in the 'RStudio' viewer pane, . Hover the mouse pointer over a cell + to show details or drag a rectangle to zoom. A 'heatmap' is a popular graphical + method for visualizing high-dimensional data, in which a table of numbers + are encoded as a grid of colored cells. The rows and columns of the matrix + are ordered to highlight patterns and are often accompanied by 'dendrograms'. + 'Heatmaps' are used in many fields for visualizing observations, correlations, + missing values patterns, and more. Interactive 'heatmaps' allow the inspection + of specific value by hovering the mouse over a cell, as well as zooming into + a region of the 'heatmap' by dragging a rectangle around the relevant area. + This work is based on the 'ggplot2' and 'plotly.js' engine. It produces + similar 'heatmaps' as 'heatmap.2' or 'd3heatmap', with the advantage of speed + ('plotly.js' is able to handle larger size matrix), the ability to zoom from + the 'dendrogram' panes, and the placing of factor variables in the sides of the + 'heatmap'. Depends: R (>= 3.0.0), plotly (>= 4.5.2), @@ -39,11 +41,14 @@ Imports: colorspace, RColorBrewer, GGally, - htmlwidgets + htmlwidgets, + assertthat Suggests: knitr, + covr, rmarkdown, - gplots + gplots, + testthat VignetteBuilder: knitr License: GPL-2 | GPL-3 URL: https://cran.r-project.org/package=heatmaply, diff --git a/NAMESPACE b/NAMESPACE index c533ffc..9b3fbc2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -35,16 +35,16 @@ export(YlGn) export(YlGnBu) export(YlOrBr) export(YlOrRd) -export(ggheatmap) export(heatmaply) export(heatmapr) export(is.heatmapr) export(is.na10) export(normalize) export(percentize) -export(side_color_plot) import(dendextend) import(ggplot2) +importFrom(assertthat,assert_that) +importFrom(dendextend,as.ggdend) importFrom(dendextend,color_branches) importFrom(dendextend,find_k) importFrom(dendextend,is.dendrogram) @@ -53,10 +53,12 @@ importFrom(dendextend,rotate) importFrom(dendextend,seriate_dendrogram) importFrom(dendextend,set) importFrom(htmlwidgets,saveWidget) +importFrom(plotly,add_segments) importFrom(plotly,config) importFrom(plotly,ggplotly) importFrom(plotly,hide_colorbar) importFrom(plotly,layout) +importFrom(plotly,plot_ly) importFrom(plotly,plotly) importFrom(plotly,plotly_empty) importFrom(plotly,subplot) diff --git a/R/ggheatmap.R b/R/ggheatmap.R deleted file mode 100644 index 497b208..0000000 --- a/R/ggheatmap.R +++ /dev/null @@ -1,85 +0,0 @@ -# -# # source: http://www.peterhaschke.com/r/2013/04/24/MultiPlot.html -# # http://rstudio-pubs-static.s3.amazonaws.com/2852_379274d7c5734f979e106dcf019ec46c.html -# multiplot <- function(..., plotlist = NULL, file, cols = 1, layout = NULL) { -# # library(grid) -# -# plots <- c(list(...), plotlist) -# -# numPlots = length(plots) -# -# if (is.null(layout)) { -# layout <- matrix(seq(1, cols * ceiling(numPlots/cols)), -# ncol = cols, nrow = ceiling(numPlots/cols)) -# } -# -# if (numPlots == 1) { -# print(plots[[1]]) -# -# } else { -# grid.newpage() -# pushViewport(viewport(layout = grid.layout(nrow(layout), ncol(layout)))) -# -# for (i in 1:numPlots) { -# matchidx <- as.data.frame(which(layout == i, arr.ind = TRUE)) -# -# print(plots[[i]], vp = viewport(layout.pos.row = matchidx$row, -# layout.pos.col = matchidx$col)) -# } -# } -# } - -# grid, -# gridExtra - -#' @title Creates a ggplot2 heatmap -#' -#' @description -#' An object of class heatmapr includes all the needed information -#' for producing a heatmap. The goal is to seperate the pre-processing of the -#' heatmap elements from the graphical rendaring of the object, which could be done -#' -#' @param x can either be a heatmapr object, or a numeric matrix -#' Defaults to \code{TRUE} unless \code{x} contains any \code{NA}s. -#' -#' @param ... other parameters passed to \link{heatmapr} (currently, various parameters may be ignored. -#' -#' @export -#' @examples -#' \dontrun{ -#' -#' library(heatmaply) -#' x <- heatmapr(iris[,-5], scale = "column", colors = "Blues") -#' ggheatmap(x) -#' -#' -#' } -ggheatmap <- function(x, ...) { - if(!is.heatmapr(x)) { - x <- heatmapr(x, ...) - } - ppxpy <- heatmaply(x, return_ppxpy = TRUE) - ggempty <- ggplot() + geom_blank() + theme_bw() - gg_list <- list(ppxpy$py, ggempty, ppxpy$p, ppxpy$px) - # gg_list <- list(ppxpy$py, ppxpy$p, ggempty, ppxpy$px) - # sapply(ppxpy, class) - # lapply(gg_list, class) - GGally::ggmatrix(gg_list, nrow = 2, ncol = 2) # in this we can't control the relative widths - # multiplot(ppxpy$py, ggempty, ppxpy$p, ppxpy$px, - - # pp <- ppxpy$p + guides(fill=FALSE) + - # theme(axis.title.x=element_blank(), - # axis.text.x=element_blank(), - # axis.ticks.x=element_blank(), - # axis.title.y=element_blank(), - # axis.text.y=element_blank(), - # axis.ticks.y=element_blank()) - # multiplot(ppxpy$py, pp , ggempty, ppxpy$px, - # layout = matrix(c(1,2,2,1,2,2,3,4,4), nrow = 3) , - # cols = 2, main = "Main title") - - # ppxpy$p + guides(fill=FALSE) - -} - - diff --git a/R/heatmaply.R b/R/heatmaply.R index 63cae77..c25eca4 100644 --- a/R/heatmaply.R +++ b/R/heatmaply.R @@ -1,12 +1,10 @@ ## TODO: roxygen documentation of all functions - # devtools::install_github("ropensci/plotly", ref = "fix/subplot") # reference: https://plot.ly/ggplot2/ggdendro-dendrograms/ # to answer later: http://stackoverflow.com/questions/34733829/questions-about-a-tutorial-regarding-interactive-heatmaps-with-plotly # to check: https://plot.ly/r/heatmaps/ - #' @title Cluster heatmap based on plotly #' @name heatmaply #' @@ -37,6 +35,11 @@ #' the third is used as the top margin, and the fourth is used as the bottom margin. #' If a single value is provided, it will be used as all four margins. #' +#' @param cellnote Mouseover values for the data. Useful if applying scaling. +#' @param draw_cellnote Should the cellnote annotations be drawn? Defaults is FALSE, +#' if cellnote is not supplied, TRUE if cellnote is supplied. If TRUE and cellnote is not supplied, +#' x will be used for cellnote. +#' #' @param Rowv determines if and how the row dendrogram should be reordered. By default, it is TRUE, which implies dendrogram is computed and reordered based on row means. If NULL or FALSE, then no dendrogram is computed and no reordering is done. If a \link{dendrogram} (or \link{hclust}), then it is used "as-is", ie without any reordering. If a vector of integers, then dendrogram is computed and reordered based on the order of the vector. #' @param Colv determines if and how the column dendrogram should be reordered. Has the options as the Rowv argument above and additionally when x is a square matrix, Colv = "Rowv" means that columns should be treated identically to the rows. #' @param distfun function used to compute the distance (dissimilarity) between both rows and columns. Defaults to dist. @@ -115,12 +118,14 @@ #' col_side_colors should be "wide", ie be the same dimensions #' as the column side colors it will produce. #' -#' @param ColSideColors,RowSideColors passed to row_side_colors,col_side_colors in order -#' to keep compatibility with \link[gplots]{heatmap.2} -#' #' @param row_side_palette,col_side_palette Color palette functions to be #' used for row_side_colors and col_side_colors respectively. #' +#' @param ColSideColors,RowSideColors passed to row_side_colors,col_side_colors in order +#' to keep compatibility with \link[gplots]{heatmap.2} +#' +#' @param plot_method Use "ggplot" or "plotly" to choose which library produces heatmap +#' and dendrogram plots #' @param seriate character indicating the method of matrix sorting (default: "OLO"). #' Implemented options include: #' "OLO" (Optimal leaf ordering, optimzes the Hamiltonian path length that is restricted by the dendrogram structure - works in O(n^4) ) @@ -142,6 +147,13 @@ #' You can relocate the file once it is created, or use \link{setwd} first. #' This is based on \link[htmlwidgets]{saveWidget}. #' +#' @param long_data Data in long format. Replaces x, so both should not be used. +#' Colnames must be c("name", "variable", "value"). If you do not have a names +#' column you can simply use a sequence of numbers from 1 to the number of "rows" +#' inthe data. +#' +#' @param label_names Names for labells of x, y and value/fill mouseover. +#' @param fontsize_row,fontsize_col,cexRow,cexCol Font size for row and column labels. #' @param subplot_widths,subplot_heights The relative widths and heights of each #' subplot. The length of these vectors will vary depending on the number of #' plots involved. @@ -243,13 +255,16 @@ #' heatmaply(x, Rowv = row_dend, Colv = col_dend) #' #' } +#' @importFrom plotly plot_ly add_segments +#' @importFrom assertthat assert_that + heatmaply <- function(x, ...) { UseMethod("heatmaply") } - #' @export #' @rdname heatmaply +#' @importFrom assertthat assert_that heatmaply.default <- function(x, # elements for scale_fill_gradientn colors = viridis(n=256, alpha = 1, begin = 0, @@ -259,10 +274,12 @@ heatmaply.default <- function(x, row_text_angle = 0, column_text_angle = 45, subplot_margin = 0, + cellnote = NULL, + draw_cellnote = !is.null(cellnote), ## dendrogram control - Rowv = TRUE, - Colv = if (symm) "Rowv" else TRUE, + Rowv, + Colv, distfun = dist, hclustfun = hclust, dist_method = NULL, @@ -300,9 +317,9 @@ heatmaply.default <- function(x, hide_colorbar = FALSE, key.title = NULL, return_ppxpy = FALSE, - row_side_colors = NULL, + row_side_colors, row_side_palette, - col_side_colors = NULL, + col_side_colors, col_side_palette, ColSideColors = NULL, RowSideColors = NULL, @@ -310,19 +327,31 @@ heatmaply.default <- function(x, heatmap_layers = NULL, branches_lwd = 0.6, file, - subplot_widths = NULL, - subplot_heights = NULL -) { - ## Suppress creation of new graphcis device, but on exit replace it. - old_dev <- options()[["device"]] - on.exit(options(device = old_dev)) - options(device = names(capabilities()[which(capabilities())])[1]) + long_data, + plot_method = c("ggplot", "plotly"), + label_names = c("row", "column", "value"), + fontsize_row = 10, + fontsize_col = 10, + cexRow, cexCol, + subplot_widths = NULL, + subplot_heights = NULL) { + + if (!missing(long_data)) { + if (!missing(x)) warning("x and long_data should not be used together") + assert_that( + ncol(long_data) == 3, + all(colnames(long_data) == c("name", "variable", "value")) + ) + x <- reshape2::dcast(long_data, name ~ variable) + rownames(x) <- x$name + x$name <- NULL + } + plot_method <- match.arg(plot_method) dendrogram <- match.arg(dendrogram) if(!(is.data.frame(x) | is.matrix(x))) stop("x must be either a data.frame or a matrix.") - if(!missing(srtRow)) row_text_angle <- srtRow if(!missing(srtCol)) column_text_angle <- srtCol @@ -333,6 +362,8 @@ heatmaply.default <- function(x, row_side_colors <- RowSideColors } + if (!missing(cexRow)) fontsize_row <- cexRow + if (!missing(cexCol)) fontsize_col <- cexCol # TODO: maybe create heatmaply.data.frame heatmaply.matrix instead. # But right now I am not sure this would be needed. @@ -349,7 +380,7 @@ heatmaply.default <- function(x, # If we have non-numeric columns, we should move them to row_side_colors # TODO: add a parameter to control removing of non-numeric columns without moving them to row_side_colors if(!all(ss_c_numeric)) { - row_side_colors <- if (is.null(row_side_colors)) { + row_side_colors <- if (missing(row_side_colors)) { data.frame(x[, !ss_c_numeric, drop= FALSE]) } else { data.frame(row_side_colors, x[, !ss_c_numeric, drop= FALSE]) @@ -370,6 +401,8 @@ heatmaply.default <- function(x, col_side_colors = col_side_colors, seriate = seriate, + cellnote = cellnote, + ## dendrogram control Rowv = Rowv, Colv = Colv, @@ -397,13 +430,12 @@ heatmaply.default <- function(x, na.rm = na.rm, ...) - hmly <- heatmaply.heatmapr(hm, # colors = colors, limits = limits, + hmly <- heatmaply.heatmapr(hm, colors = colors, limits = limits, scale_fill_gradient_fun = scale_fill_gradient_fun, grid_color = grid_color, row_text_angle = row_text_angle, column_text_angle = column_text_angle, subplot_margin = subplot_margin, - row_dend_left = row_dend_left, xlab=xlab, ylab=ylab, main = main, titleX = titleX, titleY = titleY, @@ -415,121 +447,31 @@ heatmaply.default <- function(x, row_side_palette = row_side_palette, col_side_colors = col_side_colors, col_side_palette = col_side_palette, + heatmap_layers = heatmap_layers, ColSideColors = ColSideColors, RowSideColors = RowSideColors, - heatmap_layers = heatmap_layers, branches_lwd = branches_lwd, - subplot_widths = subplot_widths, - subplot_heights = subplot_heights - ) # TODO: think more on what should be passed in "..." + label_names = label_names, + plot_method = plot_method, + draw_cellnote = draw_cellnote, + fontsize_row = fontsize_row, + fontsize_col = fontsize_col, + subplot_widths = subplot_widths, + subplot_heights = subplot_heights) + + # TODO: think more on what should be passed in "..." if(!missing(file)) hmly %>% saveWidget(file = file, selfcontained = TRUE) hmly } - - - - - - -# xx is a data matrix -ggplot_heatmap <- function(xx, - row_text_angle = 0, - column_text_angle = 45, - scale_fill_gradient_fun = - scale_fill_gradientn(colors = viridis(n=256, alpha = 1, begin = 0, - end = 1, option = "viridis"), - na.value = "grey50", limits = NULL), - grid_color = NA, - grid_size = 0.1, - key.title = NULL, - layers, - row_dend_left = FALSE, - ...) { - theme_clear_grid_heatmap <- theme(axis.line = element_line(color = "black"), - panel.grid.major = element_blank(), - panel.grid.minor = element_blank(), - panel.border = element_blank(), - panel.background = element_blank()) - # heatmap - # xx <- x$matrix$data - if(!is.data.frame(xx)) df <- as.data.frame(xx) - # colnames(df) <- x$matrix$cols - df$row <- if(!is.null(rownames(xx))) - {rownames(xx)} else - {1:nrow(xx)} - df$row <- with(df, factor(row, levels=row, ordered=TRUE)) - mdf <- reshape2::melt(df, id.vars="row") - colnames(mdf)[2] <- "column" # rename "variable" - # TODO: - # http://stackoverflow.com/questions/15921799/draw-lines-around-specific-areas-in-geom-tile - # https://cran.r-project.org/web/packages/viridis/vignettes/intro-to-viridis.html - p <- ggplot(mdf, aes_string(x = "column", y = "row")) + - geom_tile(aes_string(fill = "value"), color = grid_color, size = grid_size) + - # scale_linetype_identity() + - # scale_fill_viridis() + - coord_cartesian(expand = FALSE) + - scale_fill_gradient_fun + - theme_bw()+ theme_clear_grid_heatmap + - theme(axis.text.x = element_text(angle = column_text_angle, hjust = 1), - axis.text.y = element_text(angle = row_text_angle, hjust = 1) - ) - - if(!missing(layers)) p <- p + layers - ## Passed in to allow users to alter (courtesy of GenVisR) - - # p <- p + scale_x_discrete(limits = unique(mdf)) - # http://stats.stackexchange.com/questions/5007/how-can-i-change-the-title-of-a-legend-in-ggplot2 - p <- p + labs(fill=key.title) - - # until this bug is fixed: https://github.com/ropensci/plotly/issues/699 - # we are forced to use geom_hline and geom_vline - if(!is.na(grid_color)) { - p <- p + geom_hline(yintercept =c(0:nrow(xx))+.5, color = grid_color) # , size = grid_size # not implemented since it doesn't work with plotly - p <- p + geom_vline(xintercept =c(0:ncol(xx))+.5, color = grid_color) # , size = grid_size # not implemented since it doesn't work with plotly - - } - - if(row_dend_left) p <- p + scale_y_discrete(position = "right") # possible as of ggplot 2.1.0 ! - - p -} - - - - - - - - -# -# library(ggplot2) -# library(plotly) -# # library(heatmaply) -# ggplot_heatmap <- heatmaply:::ggplot_heatmap -# class_to <- function(x, new_class) { -# class(x) <- new_class -# x -# } -# na_mat <- function(x) { -# x %>% is.na %>% class_to("numeric") -# } -# -# p <- heatmaply:::ggplot_heatmap(na_mat(airquality), -# scale_fill_gradient_fun = scale_fill_gradientn(colors= c("white","black")) , -# grid_color = "grey", grid_size = 1) -# plot(p) -# ggplotly(p) -# p <- ggplot_heatmap(mtcars, -# grid_color = white") -# p -# heatmap_subplot_from_ggplotly <- function(p, px, py, pr, pc, row_dend_left = FALSE, subplot_margin = 0, titleX = TRUE, titleY = TRUE, - widths = NULL, heights = NULL, ...) { + widths=NULL, heights=NULL, + plot_method, ...) { + if (is.null(widths)) { if (!is.null(px)) { if (is.null(pr)) { @@ -599,27 +541,42 @@ heatmap_subplot_from_ggplotly <- function(p, px, py, pr, pc, plots <- plots[!(ind_remove_row | ind_remove_col)] ## Interim solution before removing warnings in documented way - suppressMessages(suppressWarnings( - s <- subplot(plots, - nrows = nrows, - widths = if(row_dend_left) rev(widths) else widths, - shareX = TRUE, shareY = TRUE, - titleX = titleX, titleY = titleY, - margin = subplot_margin, - heights = heights) - )) + suppressMessages( + suppressWarnings( + s <- subplot(plots, + nrows = nrows, + widths = if(row_dend_left) rev(widths) else widths, + shareX = TRUE, shareY = TRUE, + titleX = titleX, titleY = titleY, + margin = subplot_margin, + heights = heights) + ) + ) + + if (plot_method == "plotly") { + if (row_dend_left) { + num_rows <- sum(!ind_null_row) + str <- ifelse(num_rows > 1, num_rows, "") + l <- list( + anchor = paste0("x", str), + side = "right", + showticklabels=TRUE + ) + num_cols <- sum(!ind_null_col) + if (num_cols == 1) { + lay <- function(p) layout(p, yaxis = l) + } else if (num_cols == 2) { + lay <- function(p) layout(p, yaxis2 = l) + } else if (num_cols == 3) { + lay <- function(p) layout(p, yaxis3 = l) + } + + s <- lay(s) + } + } return(s) } - - - - - - - - - #' @export #' @rdname heatmaply heatmaply.heatmapr <- function(x, @@ -646,27 +603,35 @@ heatmaply.heatmapr <- function(x, hide_colorbar = FALSE, key.title = NULL, return_ppxpy = FALSE, - row_side_colors = NULL, + draw_cellnote = FALSE, + row_side_colors, row_side_palette, - col_side_colors = NULL, + col_side_colors, col_side_palette, - ColSideColors = NULL, - RowSideColors = NULL, + plot_method = c("ggplot", "plotly"), + ColSideColors, + RowSideColors, heatmap_layers = NULL, branches_lwd = 0.6, - subplot_widths = NULL, - subplot_heights = NULL - ) { + label_names, + fontsize_row = 10, + fontsize_col = 10, + subplot_widths = subplot_widths, + subplot_heights = subplot_heights) { + + plot_method <- match.arg(plot_method) + # informative errors for mis-specified limits if(!is.null(limits)) { if(!is.numeric(limits)) stop("limits must be numeric") if(length(limits) != 2L) stop("limits must be of length 2 (i.e.: two dimensional)") - r <- range(x) + r <- range(as.matrix(x$matrix$data)) l <- sort(limits) + ## Warn for broken heatmap colors - if (r[1] < l[1]) warning("Lower limit is not below lowest value in x, colors will be broken!") - if (r[2] > l[2]) warning("Upper limit is not above highest value in x, colors will be broken!") + if (l[1] > r[1]) warning("Lower limit is not <= lowest value in x, colors will be broken!") + if (l[2] < r[2]) warning("Upper limit is not >= highest value in x, colors will be broken!") } if(!missing(srtRow)) row_text_angle <- srtRow if(!missing(srtCol)) column_text_angle <- srtCol @@ -674,8 +639,6 @@ heatmaply.heatmapr <- function(x, # x is a heatmapr object. # heatmapr <- list(rows = rowDend, cols = colDend, matrix = mtx, image = imgUri, # theme = theme, options = options) - # TODO: we assume the creation of dendrograms. Other defaults should be made when the user - # chooses to not work with dendrograms. # x <- heatmapr(mtcars) # source: http://stackoverflow.com/questions/6528180/ggplot2-plot-without-axes-legends-etc theme_clear_grid_dends <- theme(axis.line=element_blank(),axis.text.x=element_blank(), @@ -699,59 +662,100 @@ heatmaply.heatmapr <- function(x, if(is.null(cols)) { py <- NULL } else { - py <- ggplot(cols, labels = FALSE) + theme_bw() + - coord_cartesian(expand = FALSE) + - theme_clear_grid_dends + if (plot_method == "ggplot") { + py <- ggplot(cols, labels = FALSE) + theme_bw() + + coord_cartesian(expand = FALSE) + + theme_clear_grid_dends + } else { + py <- plotly_dend_col(cols) + } } if(is.null(rows)) { px <- NULL } else { - px <- ggplot(rows, labels = FALSE) + - # coord_cartesian(expand = FALSE) + - coord_flip(expand = FALSE) + theme_bw() + theme_clear_grid_dends - if(row_dend_left) px <- px + scale_y_reverse() + if (plot_method == "ggplot") { + px <- ggplot(rows, labels = FALSE) + + # coord_cartesian(expand = FALSE) + + coord_flip(expand = FALSE) + theme_bw() + theme_clear_grid_dends + if(row_dend_left) px <- px + scale_y_reverse() + } else { + px <- plotly_dend_row(rows, flip = row_dend_left) + } } # create the heatmap data_mat <- x$matrix$data - p <- ggplot_heatmap(data_mat, + + if (plot_method == "ggplot") { + p <- ggplot_heatmap(data_mat, row_text_angle, column_text_angle, scale_fill_gradient_fun, grid_color, + cellnote = x$matrix$cellnote, + draw_cellnote = draw_cellnote, key.title = key.title, layers = heatmap_layers, - row_dend_left = row_dend_left) - if(return_ppxpy) { - return(list(p=p, px=px, py=py)) + row_dend_left = row_dend_left, + label_names = label_names, + fontsize_row = fontsize_row, fontsize_col = fontsize_col) + } else if (plot_method == "plotly") { + p <- plotly_heatmap(data_mat, limits = limits, colors = colors, + row_text_angle = row_text_angle, column_text_angle = column_text_angle, + fontsize_row = fontsize_row, fontsize_col = fontsize_col) } - if (is.null(row_side_colors)) pr <- NULL - else { - pr <- side_color_plot(x[["row_side_colors"]], type = "row", - palette = row_side_palette, is_colors = !is.null(RowSideColors)) + + # TODO: Add native plotly sidecolor function. + # TODO: Possibly use function to generate all 3 plots to prevent complex logic here + if (missing(row_side_colors)) { + pr <- NULL + } else { + side_color_df <- x[["row_side_colors"]] + if (is.matrix(side_color_df)) side_color_df <- as.data.frame(side_color_df) + assert_that( + nrow(side_color_df) == nrow(data_mat), + is.data.frame(side_color_df) + ) + pr <- side_color_plot(x[["row_side_colors"]], type = "row", + text_angle = row_text_angle, palette = row_side_palette, + is_colors = !is.null(RowSideColors), label_name = label_names[[1]]) } - if (is.null(col_side_colors)) pc <- NULL - else { + if (missing(col_side_colors)) { + pc <- NULL + } else { warning("The hover text for col_side_colors is currently not implemented (due to an issue in plotly). We hope this would get resolved in future releases.") - ## Have to transpose, otherwise it is the wrong orientation - side_color_df <- data.frame(t(x[["col_side_colors"]])) - + side_color_df <- x[["col_side_colors"]] + if (is.matrix(side_color_df)) side_color_df <- as.data.frame(side_color_df) + assert_that( + nrow(side_color_df) == ncol(data_mat), + is.data.frame(side_color_df) + ) ## Just make sure it's character first side_color_df[] <- lapply(side_color_df, as.character) pc <- side_color_plot(side_color_df, type = "column", - palette = col_side_palette, is_colors = !is.null(ColSideColors)) + text_angle = column_text_angle, palette = col_side_palette, + is_colors = !is.null(ColSideColors), + label_name = label_names[[2]] + ) + } + + if(return_ppxpy) { + return(list(p=p, px=px, py=py, pr=pr, pc=pc)) } ## plotly: - # turn p, px, and py to plotly objects - p <- ggplotly(p) - if(!is.null(px)) { - px <- ggplotly(px, tooltip = "y") + # turn p, px, and py to plotly objects if necessary + if (!inherits(p, "plotly")) p <- ggplotly(p) %>% layout(showlegend=FALSE) + if(!is.null(px) && !inherits(px, "plotly")) { + px <- ggplotly(px, tooltip = "y") %>% + layout(showlegend=FALSE) } - if(!is.null(py)) { - py <- ggplotly(py, tooltip = "y") + if(!is.null(py) && !inherits(py, "plotly")) { + py <- ggplotly(py, tooltip = "y") %>% + layout(showlegend=FALSE) } + # https://plot.ly/r/reference/#Layout_and_layout_style_objects p <- layout(p, # all of layout's properties: /r/reference/#layout title = main, # layout's title: /r/reference/#layout-title @@ -768,194 +772,18 @@ heatmaply.heatmapr <- function(x, # py <- hide_colorbar(py) } - # TODO: this doesn't work because of the allignment. But using this might - # speedup the code to deal with MUCH larger matrices. - # p <- plot_ly(z = xx, type = "heatmap") - # p <- plot_ly(z = xx, type = "heatmap") - # ggplotly(p) # works great - # source for: theme(axis.text.x = element_text(angle = column_text_angle, hjust = 1)) - # http://stackoverflow.com/questions/1330989/rotating-and-spacing-axis-labels-in-ggplot2 - # if(row_dend_left) p <- p + scale_y_reverse() - # # hide axis ticks and grid lines - # eaxis <- list( - # showticklabels = FALSE, - # showgrid = FALSE, - # zeroline = FALSE - # ) - # p_empty <- plot_ly() %>% - # # 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) - top_corner <- plotly_empty() - # top_corner <- ggplotly(qplot(as.numeric(xx), geom="histogram")) - # create the subplot - # Adjust top based on whether main is empty or not. if(is.na(margins[3])) margins[3] <- ifelse(main == "", 0, 30) heatmap_subplot <- heatmap_subplot_from_ggplotly(p = p, px = px, py = py, row_dend_left = row_dend_left, subplot_margin = subplot_margin, - titleX = titleX, titleY = titleY, pr = pr, pc = pc, - widths = subplot_widths, heights = subplot_heights) - l <- layout(heatmap_subplot, showlegend = FALSE) %>% - layout(margin = list(l = margins[2], b = margins[1], t = margins[3], r = margins[4])) - # print(l) - - - - # clean the modeBarButtons from irrelevent icons - # l$x$config$modeBarButtonsToRemove <- list("sendDataToCloud", "select2d", "lasso2d","autoScale2d", "hoverCompareCartesian", "sendDataToCloud") - # l <- config(l, displaylogo = FALSE, collaborate = FALSE) # , - # #modeBarButtonsToRemove = list("sendDataToCloud", "select2d", "lasso2d","autoScale2d", "hoverClosestCartesian", "hoverCompareCartesian", "sendDataToCloud")) + titleX = titleX, titleY = titleY, pr = pr, pc = pc, plot_method = plot_method) + l <- layout(heatmap_subplot, + margin = list(l = margins[2], b = margins[1], t = margins[3], r = margins[4]), + legend = list(y=1, yanchor="top") + ) l <- config(l, displaylogo = FALSE, collaborate = FALSE, modeBarButtonsToRemove = c("sendDataToCloud", "select2d", "lasso2d","autoScale2d", "hoverClosestCartesian", "hoverCompareCartesian", "sendDataToCloud")) - l } - - - - - - - - - - -# theme_set(theme_cowplot()) -# library(cowplot) -# require2(cowplot) -# -if(FALSE) { - # devtools::install_github("ropensci/plotly", ref = "fix/subplot") - # devtools::install_github('talgalili/heatmaply') - library(ggplot2) - library(dendextend) - library(plotly) - library(viridis) - #dendogram data - x <- as.matrix(scale(mtcars)) - dd.col <- as.dendrogram(hclust(dist(x))) - dd.row <- as.dendrogram(hclust(dist(t(x)))) - dd.col <- color_branches(dd.col, k = 3) - dd.row <- color_branches(dd.row, k = 2) - px <- ggplot(dd.row, labels = FALSE) + theme_bw() - py <- ggplot(dd.col, labels = FALSE) + coord_flip()+ theme_bw() - # heatmap - col.ord <- order.dendrogram(dd.col) - row.ord <- order.dendrogram(dd.row) - xx <- scale(mtcars)[col.ord, row.ord] - xx_names <- attr(xx, "dimnames") - df <- as.data.frame(xx) - colnames(df) <- xx_names[[2]] - df$car <- xx_names[[1]] - df$car <- with(df, factor(car, levels=car, ordered=TRUE)) - mdf <- reshape2::melt(df, id.vars="car") - # https://cran.r-project.org/web/packages/viridis/vignettes/intro-to-viridis.html - p <- ggplot(mdf, aes(x = variable, y = car)) + geom_tile(aes(fill = value)) + - scale_fill_viridis() + theme_bw() + - theme(axis.text.x = element_text(angle = column_text_angle, hjust = 1)) - # p <- plot_ly(z = xx, type = "heatmap") - # ggplotly(p) # works great - # ggplotly(p, tooltip = "none") - # ggplotly(px, tooltip = "") - # - # # hide axis ticks and grid lines - # eaxis <- list( - # showticklabels = FALSE, - # showgrid = FALSE, - # zeroline = FALSE - # ) - # p_empty <- plot_ly() %>% - # # 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) - s <- subplot(px, plotly_empty(), p, py, nrows = 2, widths = c(.8,.2), heights = c(.2,.8), margin = 0, - shareX = TRUE, shareY = TRUE, titleX = titleX, titleY = titleY) - layout(s, showlegend = FALSE) -} - - -#' -#' geom_tile for side color plots -#' -#' @param df A "molten" data.frame as produced by (eg) reshape2::melt -#' @param palette A function which can return colors to be used in the sidebar -#' plot -#' @param scale_title Title of the color scale. Not currently used. -#' @param type Horizontal or vertical plot? Valid values are "column" and "row" -#' @param row_text_angle,column_text_angle the angle of the text of the rows/columns. -#' @param is_colors Use if the values in df are valid colours and should not be mapped -#' to a color scheme, and instead should be plotted directly. -#' -#' @return A ggplot geom_tile object -#' -#' @export -side_color_plot <- function(df, palette, - scale_title = paste(type, "side colors"), type = c("column", "row"), - row_text_angle, column_text_angle, is_colors) { - - if (is.matrix(df)) df <- as.data.frame(df) - stopifnot(is.data.frame(df)) - - ## TODO: Find out why names are dropped when dim(df)[2] == 1 - original_dim <- dim(df) - - if (missing(column_text_angle)) column_text_angle <- 0 - if (missing(row_text_angle)) row_text_angle <- 45 - if (missing(palette)) palette <- colorspace::rainbow_hcl - - type <- match.arg(type) - if (type %in% colnames(df)) - stop("Having", type, "in the colnames of the side_color df will drop data!") - - df[[type]] <- if(!is.null(rownames(df))) rownames(df) else 1:nrow(df) - - df[[type]] <- factor(df[[type]], levels = df[[type]], ordered = TRUE) - df <- reshape2::melt(df, id.vars = type) - df[["value"]] <- factor(df[["value"]]) - - id_var <- colnames(df)[1] - if (type == "column") { - mapping <- aes_string(x = id_var, y = 'variable', fill = 'value') - if(original_dim[2] > 1) { - text_element <- element_text(angle = column_text_angle) - } else text_element <- element_blank() - - theme <- theme( - panel.background = element_blank(), - axis.text.x = element_blank(), - axis.text.y = text_element, - axis.ticks = element_blank()) - } else { - if(original_dim[2] > 1) { - text_element <- element_text(angle = row_text_angle) - } else text_element <- element_blank() - - mapping <- aes_string(x = 'variable', y = id_var, fill = 'value') - theme <- theme( - panel.background = element_blank(), - axis.text.x = text_element, - axis.text.y = element_blank(), - axis.ticks = element_blank()) - } - - color_vals <- if (is_colors) levels(df[["value"]]) - else palette(length(unique(df[["value"]]))) - - g <- ggplot(df, mapping = mapping) + - geom_raster() + - xlab("") + - ylab("") + - scale_fill_manual( - name = NULL, - breaks = levels(df[["value"]]), - values = color_vals) + - theme - return(g) -} diff --git a/R/heatmapr.R b/R/heatmapr.R index ca46fc1..57b88b8 100644 --- a/R/heatmapr.R +++ b/R/heatmapr.R @@ -76,8 +76,6 @@ #' @param digits integer indicating the number of decimal places to be used by \link{round} for 'label'. #' @param cellnote (optional) matrix of the same dimensions as \code{x} that has the human-readable version of each value, for displaying to the user on hover. If \code{NULL}, then \code{x} will be coerced using \code{\link{as.character}}. #' If missing, it will use \code{x}, after rounding it based on the \code{digits} parameter. -#' @param cellnote_scale logical (default is TRUE). IF cellnote is missing and x is used, -#' should cellnote be scaled if x is also scaled? #' #' @param cexRow positive numbers. If not missing, it will override \code{xaxis_font_size} #' and will give it a value cexRow*14 @@ -116,13 +114,12 @@ heatmapr <- function(x, ## dendrogram control - Rowv = TRUE, - Colv = if (symm) "Rowv" else TRUE, + Rowv, + Colv, distfun = dist, hclustfun = hclust, - dist_method = NULL, - hclust_method = NULL, - + dist_method = NULL, + hclust_method = NULL, distfun_row, hclustfun_row, @@ -150,8 +147,7 @@ heatmapr <- function(x, ## value formatting digits = 3L, - cellnote, - cellnote_scale = TRUE, + cellnote = NULL, ##TODO: decide later which names/conventions to keep theme = NULL, @@ -164,11 +160,9 @@ heatmapr <- function(x, brush_color = "#0000FF", show_grid = TRUE, anim_duration = 500, - - row_side_colors = NULL, - col_side_colors = NULL, + row_side_colors, + col_side_colors, seriate = c("OLO", "mean", "none", "GW"), - ... ) { @@ -239,10 +233,13 @@ heatmapr <- function(x, Rowv <- dendrogram %in% c("both", "row") } if (missing(Colv)) { - Colv <- dendrogram %in% c("both", "column") + if (dendrogram %in% c("both", "column")) { + Colv <- if (symm) "Rowv" else TRUE + } else { + Colv <- FALSE + } } - # switch("c", # "a" = 4, # "b" = 5, @@ -366,25 +363,26 @@ heatmapr <- function(x, ## reorder x (and others) ##======================= x <- x[rowInd, colInd, drop = FALSE] - if (!missing(cellnote)) + if (is.null(cellnote)) { + cellnote <- x + } else { cellnote <- cellnote[rowInd, colInd, drop = FALSE] + } - if (!is.null(row_side_colors)) { + if (!missing(row_side_colors)) { if(!(is.data.frame(row_side_colors) | is.matrix(row_side_colors))) { row_side_colors <- data.frame("row_side_colors" = row_side_colors) } - if (dim(row_side_colors)[1] != dim(x)[1]) - stop("row_side_colors and x have different numbers of rows") + assert_that(nrow(row_side_colors) == nrow(x)) row_side_colors <- row_side_colors[rowInd, , drop = FALSE] } - if (!is.null(col_side_colors)) { + if (!missing(col_side_colors)) { if( !(is.data.frame(col_side_colors) | is.matrix(col_side_colors)) ) { - col_side_colors <- matrix(col_side_colors, nrow = 1) - rownames(col_side_colors) <- "col_side_colors" + col_side_colors <- data.frame(col_side_colors) + colnames(col_side_colors) <- "col_side_colors" } - if (dim(col_side_colors)[2] != dim(x)[2]) - stop("col_side_colors and x have different numbers of columns") - col_side_colors <- col_side_colors[, colInd, drop = FALSE] + assert_that(nrow(col_side_colors) == ncol(x)) + col_side_colors <- col_side_colors[colInd, , drop = FALSE] } ## Dendrograms - Update the labels and change to dendToTree @@ -408,13 +406,10 @@ heatmapr <- function(x, rowDend <- if(is.dendrogram(Rowv)) Rowv else NULL colDend <- if(is.dendrogram(Colv)) Colv else NULL - ## Scale the data? ##==================== scale <- match.arg(scale) - if(!cellnote_scale) x_unscaled <- x #keeps a backup for cellnote - if(scale == "row") { x <- sweep(x, 1, rowMeans(x, na.rm = na.rm)) x <- sweep(x, 1, apply(x, 1, sd, na.rm = na.rm), "/") @@ -427,30 +422,27 @@ heatmapr <- function(x, ## cellnote ##==================== - if(missing(cellnote)) { - if(cellnote_scale) { - cellnote <- round(x, digits = digits) - } else { # default - cellnote <- round(x_unscaled, digits = digits) - } - } + cellnote <- round(x, digits = digits) + # Check that cellnote is o.k.: - if (is.null(dim(cellnote))) { - if (length(cellnote) != nr*nc) { - stop("Incorrect number of cellnote values") + if (!is.null(cellnote)) { + if (is.null(dim(cellnote))) { + if (length(cellnote) != nr*nc) { + stop("Incorrect number of cellnote values") + } + dim(cellnote) <- dim(x) + } + if (!identical(dim(x), dim(cellnote))) { + stop("cellnote matrix must have same dimensions as x") } - dim(cellnote) <- dim(x) - } - if (!identical(dim(x), dim(cellnote))) { - stop("cellnote matrix must have same dimensions as x") } - ## Final touches before exporting the object ##======================= - mtx <- list(data = as.matrix(cellnote), + mtx <- list(data = as.matrix(x), + cellnote = cellnote, dim = dim(x), rows = rownames(x), cols = colnames(x) @@ -489,10 +481,11 @@ heatmapr <- function(x, c(options, list(xclust_height = 0)) } - heatmapr <- list(rows = rowDend, cols = colDend, matrix = mtx, # image = imgUri, - theme = theme, options = options, - row_side_colors = row_side_colors, - col_side_colors = col_side_colors) + heatmapr <- list(rows = rowDend, cols = colDend, matrix = mtx, + theme = theme, options = options, cellnote = cellnote) + + if (!missing(row_side_colors)) heatmapr[["row_side_colors"]] <- row_side_colors + if (!missing(col_side_colors)) heatmapr[["col_side_colors"]] <- col_side_colors class(heatmapr) <- "heatmapr" diff --git a/R/percentize.R b/R/percentize.R index 94d72b8..b205ee7 100644 --- a/R/percentize.R +++ b/R/percentize.R @@ -5,7 +5,6 @@ percentize_predict <- function(x, ecdf_fun = ecdf, ...) { # x must be a data.frame ss_numeric <- sapply(x, is.numeric) - # ecdf_fun <- kCDF_fun # ecdf ecdf_list <- list() @@ -166,10 +165,7 @@ normalize.data.frame <- function(x, ...) { ss_numeric <- sapply(x, is.numeric) normalize - - for(i in which(ss_numeric)) { - x[, i] <- normalize(x[, i]) - } + x[, ss_numeric] <- lapply(x[, ss_numeric], normalize) x } diff --git a/R/plots.R b/R/plots.R new file mode 100644 index 0000000..5f00e66 --- /dev/null +++ b/R/plots.R @@ -0,0 +1,306 @@ +# xx is a data matrix +ggplot_heatmap <- function(xx, + row_text_angle = 0, + column_text_angle = 45, + scale_fill_gradient_fun = + scale_fill_gradientn(colors = viridis(n=256, alpha = 1, begin = 0, + end = 1, option = "viridis"), + na.value = "grey50", limits = NULL), + grid_color = NA, + grid_size = 0.1, + key.title = NULL, + layers, + row_dend_left = FALSE, + cellnote = NULL, + draw_cellnote = FALSE, + label_names, + fontsize_row = 10, + fontsize_col = 10, + ...) { + theme_clear_grid_heatmap <- theme(axis.line = element_line(color = "black"), + panel.grid.major = element_blank(), + panel.grid.minor = element_blank(), + panel.border = element_blank(), + panel.background = element_blank()) + # heatmap + # xx <- x$matrix$data + if(!is.data.frame(xx)) df <- as.data.frame(xx) + + if (missing(label_names)) { + if (is.null(dim_names <- names(dimnames(xx)))) { + label_names <- c("row", "column", "value") + } + } else { + assert_that(length(label_names) == 3) + } + row <- label_names[[1]] + col <- label_names[[2]] + val <- label_names[[3]] + + # colnames(df) <- x$matrix$cols + if(!is.null(rownames(xx))) { + df[[row]] <- rownames(xx) + } else { + df[[row]] <- 1:nrow(xx) + } + + df[[row]] <- factor( + df[[row]], + levels = df[[row]], + ordered = TRUE + ) + + if (!is.null(cellnote)) { + cellnote <- as.data.frame(cellnote) + # colnames(df) <- x$matrix$cols + if(!is.null(rownames(cellnote))) { + cellnote[[row]] <- rownames(cellnote) + } else { + cellnote[[row]] <- 1:nrow(cellnote) + } + cellnote[[row]] <- factor( + cellnote[[row]], + levels = cellnote[[row]], + ordered = TRUE + ) + mdf_c <- reshape2::melt(cellnote, id.vars=row) + mdf_c[, 3] <- as.factor(mdf_c[, 3]) + colnames(mdf_c)[2:3] <- c(col, val) + } + + mdf <- reshape2::melt(df, id.vars=row) + colnames(mdf)[2:3] <- c(col, val) # rename "variable" and "value" + + # TODO: + # http://stackoverflow.com/questions/15921799/draw-lines-around-specific-areas-in-geom-tile + # https://cran.r-project.org/web/packages/viridis/vignettes/intro-to-viridis.html + p <- ggplot(mdf, aes_string(x = col, y = row)) + + geom_tile(aes_string(fill = val), color = grid_color, size = grid_size) + + # scale_linetype_identity() + + # scale_fill_viridis() + + coord_cartesian(expand = FALSE) + + scale_fill_gradient_fun + + theme_bw()+ theme_clear_grid_heatmap + + theme(axis.text.x = element_text(angle = column_text_angle, + size = fontsize_col, hjust = 1), + axis.text.y = element_text(angle = row_text_angle, + size = fontsize_row, hjust = 1) + ) + + if (!is.null(cellnote) && draw_cellnote) { + p <- p + geom_text( + data = mdf_c, + mapping = aes_string(x = col, y = row, label = val)) + } + + if(!missing(layers)) p <- p + layers + ## Passed in to allow users to alter (courtesy of GenVisR) + + # p <- p + scale_x_discrete(limits = unique(mdf)) + # http://stats.stackexchange.com/questions/5007/how-can-i-change-the-title-of-a-legend-in-ggplot2 + p <- p + labs(fill=key.title) + + # until this bug is fixed: https://github.com/ropensci/plotly/issues/699 + # we are forced to use geom_hline and geom_vline + if(!is.na(grid_color)) { + p <- p + geom_hline(yintercept =c(0:nrow(xx))+.5, color = grid_color) # , size = grid_size # not implemented since it doesn't work with plotly + p <- p + geom_vline(xintercept =c(0:ncol(xx))+.5, color = grid_color) # , size = grid_size # not implemented since it doesn't work with plotly + + } + + if(row_dend_left) p <- p + scale_y_discrete(position = "right") # possible as of ggplot 2.1.0 ! + + p +} + + +plotly_heatmap <- function(x, limits = range(x), colors, + row_text_angle=0, column_text_angle=45, grid.color, grid.size, key.title, + row_dend_left, fontsize_row = 10, fontsize_col = 10) { + + plot_ly(z = x, x = 1:ncol(x), y = 1:nrow(x), + type = "heatmap", showlegend = FALSE, colors=colors, + zmin = limits[1], zmax = limits[2]) %>% + layout( + xaxis = list( + tickfont = list(size = fontsize_col), + tickangle = column_text_angle, + tickvals = 1:ncol(x), ticktext = colnames(x), + showticklabels = TRUE + ), + yaxis = list( + tickfont = list(size = fontsize_row), + tickangle = row_text_angle, + tickvals = 1:nrow(x), ticktext = rownames(x), + showticklabels = TRUE + ) + ) %>% plotly::colorbar(lenmode = "fraction", y = 0, yanchor="bottom", len=0.3) +} + + + +make_colorscale <- function(colors) { + seq <- seq(0, 1, by = 1/length(colors)) + scale <- lapply(seq_along(colors), + function(i) { + # eg + # list(c(0, "rgb(255, 0, 0)"), c(1, "rgb(0, 255, 0)")), + if (i == 1) { + list(0, col2plotlyrgb(colors[i])) + } else if (i == length(colors)) { + list(1, col2plotlyrgb(colors[i])) + } else { + list(seq[i], col2plotlyrgb(colors[i])) + } + } + ) + scale +} + +col2plotlyrgb <- function(col) { + rgb <- grDevices::col2rgb(col) + paste0( + "rgb(", + rgb["red", ], ",", + rgb["green", ], ",", + rgb["blue", ], ")" + ) +} + +#' @importFrom dendextend as.ggdend +plotly_dend_row <- function(dend, flip = FALSE) { + dend_data <- as.ggdend(dend) + segs <- dend_data$segments + p <- plot_ly(segs) %>% + add_segments(x = ~y, xend = ~yend, y = ~x, yend = ~xend, + line=list(color = '#000000'), showlegend = FALSE, hoverinfo = "none") %>% + layout( + hovermode = "closest", + xaxis = list( + title = "", + linecolor = "#ffffff", + showgrid = FALSE + ), + yaxis = list( + title = "", + range = c(0, max(segs$x) + 1), + linecolor = "#ffffff", + showgrid = FALSE + ) + ) + + if (flip) { + p <- layout(p, xaxis = list(autorange = "reversed")) + } + p +} + + +plotly_dend_col <- function(dend, flip = FALSE) { + dend_data <- as.ggdend(dend) + segs <- dend_data$segments + + plot_ly(segs) %>% + add_segments(x = ~x, xend = ~xend, y = ~y, yend = ~yend, + line = list(color='#000000'), showlegend = FALSE, hoverinfo = "none") %>% + layout( + hovermode = "closest", + xaxis = list( + title = "", + range = c(0, max(segs$x) + 1), + linecolor = "#ffffff", + showgrid = FALSE + ), + yaxis = list( + title = "", + linecolor = "#ffffff", + showgrid = FALSE + ) + ) +} + + + + +#' +#' geom_tile for side color plots +#' +#' @param df A "molten" data.frame as produced by (eg) reshape2::melt +#' @param palette A function which can return colors to be used in the sidebar +#' plot +#' @param scale_title Title of the color scale. Not currently used. +#' @param type Horizontal or vertical plot? Valid values are "column" and "row" +#' @param text_angle the angle of the text of the rows/columns. +#' @param is_colors Use if the values in df are valid colours and should not be mapped +#' to a color scheme, and instead should be plotted directly. +#' @param label_name Name for the mouseover label, usually "row" or "column" +#' +#' @return A ggplot geom_tile object +side_color_plot <- function(df, palette, + scale_title = paste(type, "side colors"), type = c("column", "row"), + text_angle = if (type == "row") 0 else 90, is_colors = FALSE, + label_name = type) { + + if (is.matrix(df)) df <- as.data.frame(df) + assert_that(is.data.frame(df)) + + ## Cooerce to character + df[] <- lapply(df, as.character) + + ## TODO: Find out why names are dropped when dim(df)[2] == 1 + original_dim <- dim(df) + + if (missing(palette)) palette <- colorspace::rainbow_hcl + + type <- match.arg(type) + ## Custom label + if (!missing(label_name)) type <- label_name + if (type %in% colnames(df)) + stop("Having", type, "in the colnames of the side_color df will drop data!") + + df[[type]] <- if(!is.null(rownames(df))) rownames(df) else 1:nrow(df) + + df[[type]] <- factor(df[[type]], levels = df[[type]], ordered = TRUE) + df <- reshape2::melt(df, id.vars = type) + df[["value"]] <- factor(df[["value"]]) + + id_var <- colnames(df)[1] + + if (type == "column") { + mapping <- aes_string(x = id_var, y = "variable", fill = "value") + if(original_dim[2] > 1) { + text_element <- element_text(angle = text_angle) + } else text_element <- element_blank() + + theme <- theme( + panel.background = element_blank(), + axis.text.x = element_blank(), + axis.text.y = text_element, + axis.ticks = element_blank()) + } else { + if(original_dim[2] > 1) { + text_element <- element_text(angle = text_angle) + } else text_element <- element_blank() + + mapping <- aes_string(x = "variable", y = id_var, fill = "value") + theme <- theme( + panel.background = element_blank(), + axis.text.x = text_element, + axis.text.y = element_blank(), + axis.ticks = element_blank()) + } + + color_vals <- if (is_colors) levels(df[["value"]]) + else palette(nlevels(df[["value"]])) + + g <- ggplot(df, mapping = mapping) + + geom_raster() + + xlab("") + + ylab("") + + scale_fill_manual( + name = NULL, + breaks = levels(df[["value"]]), + values = color_vals) + + theme + return(g) +} diff --git a/man/ggheatmap.Rd b/man/ggheatmap.Rd deleted file mode 100644 index 58577bd..0000000 --- a/man/ggheatmap.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ggheatmap.R -\name{ggheatmap} -\alias{ggheatmap} -\title{Creates a ggplot2 heatmap} -\usage{ -ggheatmap(x, ...) -} -\arguments{ -\item{x}{can either be a heatmapr object, or a numeric matrix -Defaults to \code{TRUE} unless \code{x} contains any \code{NA}s.} - -\item{...}{other parameters passed to \link{heatmapr} (currently, various parameters may be ignored.} -} -\description{ -An object of class heatmapr includes all the needed information -for producing a heatmap. The goal is to seperate the pre-processing of the -heatmap elements from the graphical rendaring of the object, which could be done -} -\examples{ -\dontrun{ - -library(heatmaply) -x <- heatmapr(iris[,-5], scale = "column", colors = "Blues") -ggheatmap(x) - - -} -} diff --git a/man/heatmaply.Rd b/man/heatmaply.Rd index 94a87ba..153685e 100644 --- a/man/heatmaply.Rd +++ b/man/heatmaply.Rd @@ -11,20 +11,23 @@ heatmaply(x, ...) \method{heatmaply}{default}(x, colors = viridis(n = 256, alpha = 1, begin = 0, end = 1, option = "viridis"), limits = NULL, na.value = "grey50", row_text_angle = 0, column_text_angle = 45, subplot_margin = 0, - Rowv = TRUE, Colv = if (symm) "Rowv" else TRUE, distfun = dist, - hclustfun = hclust, dist_method = NULL, hclust_method = NULL, - distfun_row, hclustfun_row, distfun_col, hclustfun_col, - dendrogram = c("both", "row", "column", "none"), reorderfun = function(d, - w) reorder(d, w), k_row, k_col, symm = FALSE, revC, scale = c("none", - "row", "column"), na.rm = TRUE, row_dend_left = FALSE, margins = c(50, - 50, NA, 0), ..., scale_fill_gradient_fun = scale_fill_gradientn(colors = if + cellnote = NULL, draw_cellnote = !is.null(cellnote), Rowv, Colv, + distfun = dist, hclustfun = hclust, dist_method = NULL, + hclust_method = NULL, distfun_row, hclustfun_row, distfun_col, + hclustfun_col, dendrogram = c("both", "row", "column", "none"), + reorderfun = function(d, w) reorder(d, w), k_row, k_col, symm = FALSE, + revC, scale = c("none", "row", "column"), na.rm = TRUE, + row_dend_left = FALSE, margins = c(50, 50, NA, 0), ..., + scale_fill_gradient_fun = scale_fill_gradientn(colors = if (is.function(colors)) colors(256) else colors, na.value = na.value, limits = limits), grid_color = NA, srtRow, srtCol, xlab = "", ylab = "", main = "", titleX = TRUE, titleY = TRUE, hide_colorbar = FALSE, - key.title = NULL, return_ppxpy = FALSE, row_side_colors = NULL, - row_side_palette, col_side_colors = NULL, col_side_palette, - ColSideColors = NULL, RowSideColors = NULL, seriate = c("OLO", "mean", - "none", "GW"), heatmap_layers = NULL, branches_lwd = 0.6, file, + key.title = NULL, return_ppxpy = FALSE, row_side_colors, row_side_palette, + col_side_colors, col_side_palette, ColSideColors = NULL, + RowSideColors = NULL, seriate = c("OLO", "mean", "none", "GW"), + heatmap_layers = NULL, branches_lwd = 0.6, file, long_data, + plot_method = c("ggplot", "plotly"), label_names = c("row", "column", + "value"), fontsize_row = 10, fontsize_col = 10, cexRow, cexCol, subplot_widths = NULL, subplot_heights = NULL) \method{heatmaply}{heatmapr}(x, colors = viridis(n = 256, alpha = 1, begin = @@ -35,10 +38,12 @@ heatmaply(x, ...) (is.function(colors)) colors(256) else colors, na.value = na.value, limits = limits), grid_color = NA, srtRow, srtCol, xlab = "", ylab = "", main = "", titleX = TRUE, titleY = TRUE, hide_colorbar = FALSE, - key.title = NULL, return_ppxpy = FALSE, row_side_colors = NULL, - row_side_palette, col_side_colors = NULL, col_side_palette, - ColSideColors = NULL, RowSideColors = NULL, heatmap_layers = NULL, - branches_lwd = 0.6, subplot_widths = NULL, subplot_heights = NULL) + key.title = NULL, return_ppxpy = FALSE, draw_cellnote = FALSE, + row_side_colors, row_side_palette, col_side_colors, col_side_palette, + plot_method = c("ggplot", "plotly"), ColSideColors, RowSideColors, + heatmap_layers = NULL, branches_lwd = 0.6, label_names, + fontsize_row = 10, fontsize_col = 10, subplot_widths = subplot_widths, + subplot_heights = subplot_heights) } \arguments{ \item{x}{can either be a heatmapr object, or a numeric matrix @@ -66,6 +71,12 @@ the first is used as the left margin, the second is used as the right margin, the third is used as the top margin, and the fourth is used as the bottom margin. If a single value is provided, it will be used as all four margins.} +\item{cellnote}{Mouseover values for the data. Useful if applying scaling.} + +\item{draw_cellnote}{Should the cellnote annotations be drawn? Defaults is FALSE, +if cellnote is not supplied, TRUE if cellnote is supplied. If TRUE and cellnote is not supplied, +x will be used for cellnote.} + \item{Rowv}{determines if and how the row dendrogram should be reordered. By default, it is TRUE, which implies dendrogram is computed and reordered based on row means. If NULL or FALSE, then no dendrogram is computed and no reordering is done. If a \link{dendrogram} (or \link{hclust}), then it is used "as-is", ie without any reordering. If a vector of integers, then dendrogram is computed and reordered based on the order of the vector.} \item{Colv}{determines if and how the column dendrogram should be reordered. Has the options as the Rowv argument above and additionally when x is a square matrix, Colv = "Rowv" means that columns should be treated identically to the rows.} @@ -181,6 +192,18 @@ This should not include a directory, only the name of the file. You can relocate the file once it is created, or use \link{setwd} first. This is based on \link[htmlwidgets]{saveWidget}.} +\item{long_data}{Data in long format. Replaces x, so both should not be used. +Colnames must be c("name", "variable", "value"). If you do not have a names +column you can simply use a sequence of numbers from 1 to the number of "rows" +inthe data.} + +\item{plot_method}{Use "ggplot" or "plotly" to choose which library produces heatmap +and dendrogram plots} + +\item{label_names}{Names for labells of x, y and value/fill mouseover.} + +\item{fontsize_row, fontsize_col, cexRow, cexCol}{Font size for row and column labels.} + \item{subplot_widths, subplot_heights}{The relative widths and heights of each subplot. The length of these vectors will vary depending on the number of plots involved.} diff --git a/man/heatmapr.Rd b/man/heatmapr.Rd index 23089af..98be93f 100644 --- a/man/heatmapr.Rd +++ b/man/heatmapr.Rd @@ -7,18 +7,17 @@ The interface was designed based on \link{heatmap}, \link[gplots]{heatmap.2}, and \link[d3heatmap]{d3heatmap}. } \usage{ -heatmapr(x, Rowv = TRUE, Colv = if (symm) "Rowv" else TRUE, - distfun = dist, hclustfun = hclust, dist_method = NULL, - hclust_method = NULL, distfun_row, hclustfun_row, distfun_col, - hclustfun_col, dendrogram = c("both", "row", "column", "none"), +heatmapr(x, Rowv, Colv, distfun = dist, hclustfun = hclust, + dist_method = NULL, hclust_method = NULL, distfun_row, hclustfun_row, + distfun_col, hclustfun_col, dendrogram = c("both", "row", "column", "none"), reorderfun = function(d, w) reorder(d, w), k_row, k_col, symm = FALSE, revC, scale = c("none", "row", "column"), na.rm = TRUE, labRow = rownames(x), labCol = colnames(x), cexRow, cexCol, digits = 3L, - cellnote, cellnote_scale = TRUE, theme = NULL, colors = "RdYlBu", - width = NULL, height = NULL, xaxis_height = 80, yaxis_width = 120, + cellnote = NULL, theme = NULL, colors = "RdYlBu", width = NULL, + height = NULL, xaxis_height = 80, yaxis_width = 120, xaxis_font_size = NULL, yaxis_font_size = NULL, brush_color = "#0000FF", - show_grid = TRUE, anim_duration = 500, row_side_colors = NULL, - col_side_colors = NULL, seriate = c("OLO", "mean", "none", "GW"), ...) + show_grid = TRUE, anim_duration = 500, row_side_colors, col_side_colors, + seriate = c("OLO", "mean", "none", "GW"), ...) } \arguments{ \item{x}{A numeric matrix @@ -83,9 +82,6 @@ and will give it a value cexCol*14} \item{cellnote}{(optional) matrix of the same dimensions as \code{x} that has the human-readable version of each value, for displaying to the user on hover. If \code{NULL}, then \code{x} will be coerced using \code{\link{as.character}}. If missing, it will use \code{x}, after rounding it based on the \code{digits} parameter.} -\item{cellnote_scale}{logical (default is TRUE). IF cellnote is missing and x is used, -should cellnote be scaled if x is also scaled?} - \item{theme}{A custom CSS theme to use. Currently the only valid values are \code{""} and \code{"dark"}. \code{"dark"} is primarily intended for standalone visualizations, not R Markdown or Shiny.} diff --git a/man/side_color_plot.Rd b/man/side_color_plot.Rd index 77478e2..6aaafb7 100644 --- a/man/side_color_plot.Rd +++ b/man/side_color_plot.Rd @@ -1,11 +1,12 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/heatmaply.R +% Please edit documentation in R/plots.R \name{side_color_plot} \alias{side_color_plot} \title{geom_tile for side color plots} \usage{ side_color_plot(df, palette, scale_title = paste(type, "side colors"), - type = c("column", "row"), row_text_angle, column_text_angle, is_colors) + type = c("column", "row"), text_angle = if (type == "row") 0 else 90, + is_colors = FALSE, label_name = type) } \arguments{ \item{df}{A "molten" data.frame as produced by (eg) reshape2::melt} @@ -17,10 +18,12 @@ plot} \item{type}{Horizontal or vertical plot? Valid values are "column" and "row"} -\item{row_text_angle, column_text_angle}{the angle of the text of the rows/columns.} +\item{text_angle}{the angle of the text of the rows/columns.} \item{is_colors}{Use if the values in df are valid colours and should not be mapped to a color scheme, and instead should be plotted directly.} + +\item{label_name}{Name for the mouseover label, usually "row" or "column"} } \value{ A ggplot geom_tile object diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 0000000..bb209dd --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,4 @@ +library(testthat) +library(heatmaply) + +test_check("heatmaply") diff --git a/tests/testthat/test_heatmaply.R b/tests/testthat/test_heatmaply.R new file mode 100644 index 0000000..20bb967 --- /dev/null +++ b/tests/testthat/test_heatmaply.R @@ -0,0 +1,184 @@ +for (plot_method in c("ggplot", "plotly")) { + for (bool in c(TRUE, FALSE)) { + + context(paste0(plot_method, ", row_dend_left=", bool)) + + test_that("heatmaply mtcars (both dend)", { + h <- heatmaply(mtcars, row_dend_left = bool, + plot_method = plot_method) + expect_is(h, "plotly") + + }) + + test_that("heatmaply mtcars (no dend)", { + h <- heatmaply(mtcars, dendrogram = "none", row_dend_left = bool, + plot_method = plot_method) + expect_is(h, "plotly") + }) + + test_that("heatmaply mtcars (coldend only)", { + h <- heatmaply(mtcars, dendrogram = "col", row_dend_left = bool, + plot_method = plot_method) + expect_is(h, "plotly") + }) + + test_that("heatmaply mtcars (rowdend only)", { + h <- heatmaply(mtcars, dendrogram = "row", row_dend_left = bool, + plot_method = plot_method) + expect_is(h, "plotly") + }) + + + test_that("heatmaply mtcars (rscols, both dend)", { + h <- heatmaply(mtcars, + row_side_colors = mtcars[, 1:2], row_dend_left = bool, + plot_method = plot_method) + expect_is(h, "plotly") + }) + + + test_that("heatmaply mtcars (rscols, row dend)", { + h <- heatmaply(mtcars, dendrogram = "none", + row_side_colors = mtcars[, 1:2], + row_dend_left = bool, + plot_method = plot_method) + expect_is(h, "plotly") + }) + + test_that("heatmaply mtcars (rscols, row dend)", { + h <- heatmaply(mtcars, dendrogram = "col", + row_side_colors = mtcars[, 1:2], + row_dend_left = bool, + plot_method = plot_method) + expect_is(h, "plotly") + }) + + test_that("heatmaply mtcars (rscols, no dends)", { + h <- heatmaply(mtcars, dendrogram = "none", + row_side_colors = mtcars[, 1:2], row_dend_left = bool, + plot_method = plot_method) + expect_is(h, "plotly") + }) + + test_that("heatmaply mtcars (cscols, both dend)", { + expect_warning(h <- heatmaply(mtcars, + col_side_colors = data.frame(t(mtcars[1:2, ])), + row_dend_left = bool, + plot_method = plot_method)) + expect_is(h, "plotly") + }) + + test_that("heatmaply mtcars (cscols, col dend)", { + expect_warning(h <- heatmaply(mtcars, dendrogram = "col", + col_side_colors = data.frame(t(mtcars[1:2, ])), + row_dend_left = bool, + plot_method = plot_method)) + expect_is(h, "plotly") + }) + + test_that("heatmaply mtcars (cscols, row dend)", { + expect_warning(h <- heatmaply(mtcars, dendrogram = "row", + col_side_colors = data.frame(t(mtcars[1:2, ])), + row_dend_left = bool, + plot_method = plot_method)) + expect_is(h, "plotly") + }) + + test_that("heatmaply mtcars (cscols, no dend)", { + expect_warning(h <- heatmaply(mtcars, dendrogram = "none", + col_side_colors = data.frame(t(mtcars[1:2, ])), + row_dend_left = bool, + plot_method = plot_method)) + expect_is(h, "plotly") + }) + + test_that("heatmaply mtcars (rcscols, both dend)", { + expect_warning(h <- heatmaply(mtcars, + row_side_colors = mtcars[, 1:2], + col_side_colors = data.frame(t(mtcars[1:2, ])), + row_dend_left = bool, + plot_method = plot_method)) + expect_is(h, "plotly") + }) + + test_that("heatmaply mtcars (rcscols, col dend)", { + expect_warning(h <- heatmaply(mtcars, dendrogram = "col", + row_side_colors = mtcars[, 1:2], + col_side_colors = data.frame(t(mtcars[1:2, ])), + row_dend_left = bool, + plot_method = plot_method)) + expect_is(h, "plotly") + }) + + test_that("heatmaply mtcars (rcscols, row dend)", { + expect_warning(h <- heatmaply(mtcars, dendrogram = "row", + row_side_colors = mtcars[, 1:2], + col_side_colors = data.frame(t(mtcars[1:2, ])), + row_dend_left = bool, + plot_method = plot_method)) + expect_is(h, "plotly") + }) + + test_that("heatmaply mtcars (rcscols, no dend)", { + expect_warning(h <- heatmaply(mtcars, dendrogram = "none", + row_side_colors = mtcars[, 1:2], + col_side_colors = data.frame(t(mtcars[1:2, ])), + row_dend_left = bool, + plot_method = plot_method)) + expect_is(h, "plotly") + }) + } +} + + +context("heatmaply misc") + + +test_that("non-numerics moved to row_side_colors", { + mtcars[, ncol(mtcars) + 1] <- "a" + h <- heatmaply(mtcars, row_side_colors = mtcars[, 1:2]) + expect_is(h, "plotly") + h <- heatmaply(mtcars) + expect_is(h, "plotly") +}) + + +test_that("heatmaply on matrix, and cexRow/Col", { + mtcars <- as.matrix(mtcars) + rownames(mtcars) <- NULL + h <- heatmaply(mtcars, cexRow = 5, cexCol = 5) + expect_warning(heatmaply(mtcars, cexRow = "b", cexCol = "a")) + + expect_is(h, "plotly") +}) + + +test_that("grid_color and hide_colorbar", { + h <- heatmaply(mtcars, grid_color = "black", hide_colorbar = TRUE) + expect_is(h, "plotly") +}) + +test_that("return plots", { + h <- heatmaply(mtcars, return_ppxpy = TRUE) + sapply(h, function(el) expect_true(is.null(el) | inherits(el, "gg"))) +}) + +test_that("SideColors", { + rs <- mtcars[, 1] + rscolors <- colorRampPalette(c("red", "blue"))(length(unique(rs))) + rs <- rscolors[as.character(rs)] + h <- heatmaply(mtcars, RowSideColors = rs) + expect_is(h, "plotly") + expect_warning(h <- heatmaply(t(mtcars), ColSideColors = rs)) + expect_is(h, "plotly") +}) + +test_that("limits", { + h <- heatmaply(t(mtcars), limits = range(as.matrix(mtcars))) + expect_is(h, "plotly") + expect_warning(h <- heatmaply(t(mtcars), limits = c(0, 0))) + expect_is(h, "plotly") + expect_error(heatmaply(t(mtcars), limits = c("a", "b"))) + expect_error(heatmaply(t(mtcars), limits = 1)) +}) + diff --git a/tests/testthat/test_heatmapr.R b/tests/testthat/test_heatmapr.R new file mode 100644 index 0000000..8e0dc1e --- /dev/null +++ b/tests/testthat/test_heatmapr.R @@ -0,0 +1,20 @@ +context("heatmapr") + +test_that("seriate", { + expect_is(heatmapr(mtcars, seriate = "GW"), "heatmapr") +}) + + +test_that("Rowv, Colv", { + expect_is(heatmapr(mtcars, Colv = 1:ncol(mtcars), Rowv = 1:ncol(mtcars)), + "heatmapr") +}) + +test_that("symm, revc", { + expect_is(heatmapr(cor(mtcars), revC = TRUE), "heatmapr") +}) + +test_that("scale", { + expect_is(h1 <- heatmapr(cor(mtcars), scale = "row", symm=TRUE), "heatmapr") + expect_is(h2 <- heatmapr(cor(mtcars), scale = "col", symm=TRUE), "heatmapr") +}) diff --git a/tests/testthat/test_misc.R b/tests/testthat/test_misc.R new file mode 100644 index 0000000..a858421 --- /dev/null +++ b/tests/testthat/test_misc.R @@ -0,0 +1,21 @@ +context("misc") + +test_that("is.na10", { + tf <- rep(c(NA, FALSE), length.out = 10) + expect_equal(is.na10(tf), as.integer(is.na(tf))) +}) + +test_that("normalize", { + a <- seq(0,1, by=0.01) + expect_equal(normalize(a), a) + b <- 1:1000000 + expect_true(all(normalize(b) <= 1 && all(normalize(b) >= 0))) + + d <- data.frame(a=a[1:101], b=b[1:101], c="c") + dn <- normalize(d) + expect_equal(normalize(d[, 1:2]), normalize(as.matrix(d[, 1:2]))) + expect_equal(dn[, 1], a) + expect_true(all(dn[[3]] == "c")) +}) + + diff --git a/vignettes/.build.timestamp b/vignettes/.build.timestamp new file mode 100644 index 0000000..e69de29 diff --git a/vignettes/heatmaply.R b/vignettes/heatmaply.R new file mode 100644 index 0000000..7b64ddb --- /dev/null +++ b/vignettes/heatmaply.R @@ -0,0 +1,30 @@ +## ---- echo = FALSE, message = FALSE-------------------------------------- +library(heatmaply) +library(knitr) +knitr::opts_chunk$set( + # cache = TRUE, + dpi = 60, + comment = "#>", + tidy = FALSE) + +# http://stackoverflow.com/questions/24091735/why-pandoc-does-not-retrieve-the-image-file +# < ! -- rmarkdown v1 --> + + +## ---- eval = FALSE------------------------------------------------------- +# install.packages('heatmaply') + +## ---- eval = FALSE------------------------------------------------------- +# # You'll need devtools +# install.packages.2 <- function (pkg) if (!require(pkg)) install.packages(pkg); +# install.packages.2('devtools') +# # make sure you have Rtools installed first! if not, then run: +# #install.packages('installr'); install.Rtools() +# +# devtools::install_github("ropensci/plotly") +# devtools::install_github('talgalili/heatmaply') +# + +## ------------------------------------------------------------------------ +library("heatmaply") + diff --git a/vignettes/heatmaply.Rmd b/vignettes/heatmaply.Rmd index 32a4c22..cfdfb5b 100644 --- a/vignettes/heatmaply.Rmd +++ b/vignettes/heatmaply.Rmd @@ -84,13 +84,15 @@ library(heatmaply) heatmaply(mtcars) ``` -Because the labels are somewhat long, we need to manually fix the margins (hopefully this will be fixed in future versions of plot.ly). This also allows the inclusion of xlab/ylab/main texts. +It is probably more useful to use scaling. heatmaply supports column +and row scaling using the "scale" parameter. +Because the labels are somewhat long, we need to manually fix the margins (hopefully this will be fixed in future versions of plotly). This also allows the inclusion of xlab/ylab/main texts. ```{r} heatmaply(mtcars, xlab = "Features", ylab = "Cars", main = "An example of title and xlab/ylab", - margins = c(60,100,40,20) ) -# heatmaply(mtcars) %>% layout(margin = list(l = 130, b = 40)) + scale = "column", + margins = c(60,100,40,20)) ``` We can use this with correlation. Notice the use of limits to set the range of the colors, and how we color the branches: @@ -105,30 +107,32 @@ heatmaply(cor(mtcars), margins = c(40, 40), Various seriation options ------------------- -heatmaply uses the `seriation` package to find optimal ordering of rows and columns. Optimal means to optimze the Hamiltonian path length that is restricted by the dendrogram structure. Which, in other words, means to rotate the branches so that the sum of distances between each adjacent leaf (label) will be minimized. This is related to a restricted version of the travel salesman problem. The default options is "OLO" (Optimal leaf ordering) which optimizes the above mention critirion (it works in O(n^4)). Another option is "GW" (Gruvaeus and Wainer) which aims for the same goal but uses a (faster?) heuristic. The option "mean" gives the output we would get by default from heatmap functions in other packages such as `gplots::heatmap.2`. The option "none" gives us the dendrograms without any rotation. +heatmaply uses the `seriation` package to find an optimal ordering of rows and columns. Optimal means to optimze the Hamiltonian path length that is restricted by the dendrogram structure. This, in other words, means to rotate the branches so that the sum of distances between each adjacent leaf (label) will be minimized. This is related to a restricted version of the travelling salesman problem. + +The default options is "OLO" (Optimal leaf ordering) which optimizes the above criterion (in O(n^4)). Another option is "GW" ([Gruvaeus and Wainer](https://www.researchgate.net/publication/230266994_Two_additions_to_hierarchical_cluster_analysis)) which aims for the same goal but uses a potentially faster heuristic. The option "mean" gives the output we would get by default from heatmap functions in other packages such as `gplots::heatmap.2`. The option "none" gives us the dendrograms without any rotation. ```{r} # The default of heatmaply: heatmaply(mtcars[1:10,], margins = c(40, 130), - seriate = "OLO") + seriate = "OLO", scale = "column") ``` ```{r} # Similar to OLO but less optimal (since it is a heuristic) heatmaply(mtcars[1:10,], margin = c(40, 130), - seriate = "GW") + seriate = "GW", scale = "column") ``` ```{r} # the default by gplots::heatmaply.2 heatmaply(mtcars[1:10,], margins = c(40, 130), - seriate = "mean") + seriate = "mean", scale = "column") ``` ```{r} # the default output from hclust heatmaply(mtcars[1:10,], margins = c(40, 130), - seriate = "none") + seriate = "none", scale = "column") ``` This works heavily relies on the seriation package (their [vignette](https://CRAN.R-project.org/package=seriation/vignettes/seriation.pdf) is well worth the read), and also lightly on the dendextend package (see [vignette](https://CRAN.R-project.org/package=dendextend/vignettes/introduction.html) ) @@ -155,7 +159,7 @@ col_dend <- x %>% t %>% dist %>% hclust %>% as.dendrogram %>% ladderize # rotate_DendSer(ser_weight = dist(t(x))) -heatmaply(x, Rowv = row_dend, Colv = col_dend) +heatmaply(x, Rowv = row_dend, Colv = col_dend, scale = "column") ``` @@ -165,7 +169,7 @@ heatmaply(x, Rowv = row_dend, Colv = col_dend) Changing color palettes ------------------- -We can use different colors than the default `viridis`. For example, we may want to use other color pallates in order to get divergent colors for the correlations (these will sadly be less friendly for color blind people): +We can use colors other than the default `viridis`. For example, we may want to use other color palettes in order to get divergent colors for the correlations (these will, sadly, be less useful for colorblind people): ```{r} # divergent_viridis_magma <- c(rev(viridis(100, begin = 0.3)), magma(100, begin = 0.3)) @@ -188,13 +192,13 @@ Another example for using colors: ```{r} heatmaply(mtcars, margins = c(40, 130), - colors = heat.colors(100)) + colors = heat.colors(100), scale = "column") ``` Or even more customized colors using `scale_fill_gradient_fun`: ```{r} -heatmaply(mtcars, margins = c(40, 130), +heatmaply(mtcars, margins = c(40, 130), scale = "column", scale_fill_gradient_fun = ggplot2::scale_fill_gradient2(low = "blue", high = "red", midpoint = 200, limits = c(0, 500))) ``` @@ -212,7 +216,7 @@ library(heatmaply) airquality[1:10,] %>% is.na10 %>% heatmaply(color = c("white","black"), grid_color = "grey", k_col =3, k_row = 3, - margins = c(40, 50)) + margins = c(40, 50), scale = "column") # airquality %>% is.na10 %>% # heatmaply(color = c("grey80", "grey20"), # grid_color = "grey", @@ -235,7 +239,7 @@ x <- as.matrix(datasets::mtcars) gplots::heatmap.2(x, trace = "none", col = viridis(100), key = FALSE) ``` -And heatmaply (the only difference is the side of the row dendrogram. This might be possible to modify in future versions of ggplot/plotly/heatmaply): +With heatmaply, the only difference is the side of the row dendrogram. This might be possible to modify in future versions of heatmaply: ```{r} heatmaply::heatmaply(x, seriate = "mean") diff --git a/vignettes/heatmaply.md b/vignettes/heatmaply.md new file mode 100644 index 0000000..4233449 --- /dev/null +++ b/vignettes/heatmaply.md @@ -0,0 +1,106 @@ +--- +title: "Introduction to heatmaply" +date: "2017-04-03" +author: "Tal Galili" +output: + html_document: + self_contained: yes + toc: true +--- + + + + + + +**Author**: [Tal Galili](http://www.r-statistics.com/) ( Tal.Galili@gmail.com ) + + + +Introduction +============ + +A heatmap is a popular graphical method for visualizing high-dimensional data, in which a table of numbers are encoded as a grid of colored cells. The rows and columns of the matrix are ordered to highlight patterns and are often accompanied by dendrograms. Heatmaps are used in many fields for visualizing observations, correlations, missing values patterns, and more. + +Interactive heatmaps allow the inspection of specific value by hovering the mouse over a cell, as well as zooming into a region of the heatmap by draging a rectangle around the relevant area. + +This work is based on the ggplot2 and plotly.js engine. It produces similar heatmaps as d3heatmap, with the advantage of speed (plotly.js is able to handle larger size matrix), and the ability to zoom from the dendrogram. + + +Installation +============ + +To install the stable version on CRAN: + + +```r +install.packages('heatmaply') +``` + +To install the GitHub version: + + +```r +# You'll need devtools +install.packages.2 <- function (pkg) if (!require(pkg)) install.packages(pkg); +install.packages.2('devtools') +# make sure you have Rtools installed first! if not, then run: +#install.packages('installr'); install.Rtools() + +devtools::install_github("ropensci/plotly") +devtools::install_github('talgalili/heatmaply') +``` + + +And then you may load the package using: + + +```r +library("heatmaply") +``` + +Usage +====== + + +Default +------------- + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +