|
| 1 | +NULL |
| 2 | + |
| 3 | +`%||%` <- function(a, b) { |
| 4 | + if (!is.null(a)) |
| 5 | + a |
| 6 | + else |
| 7 | + b |
| 8 | +} |
| 9 | + |
| 10 | + |
| 11 | +#' Morpheus Heatmap widget |
| 12 | +#' |
| 13 | +#' Creates a morpheus.js-based heatmap widget. |
| 14 | +#' |
| 15 | +#' @param x numeric matrix of the values to be plotted. |
| 16 | +#' @param labRow character vectors with row labels to use (from top to bottom); default to rownames(x). |
| 17 | +#' @param labCol character vectors with column labels to use (from left to right); default to colnames(x). |
| 18 | +#' @param Rowv determines if and how the row dendrogram should be computed and reordered. Either a dendrogram or a vector of values used to reorder the row dendrogram or NA to suppress any row dendrogram (and reordering) or by default, NULL, see ‘Details’ below. |
| 19 | +#' @param Colv determines if and how the column dendrogram should be reordered. Has the same 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 (and so if there is to be no row dendrogram there will not be a column one either). |
| 20 | +#' @param distfun function used to compute the distance (dissimilarity) between both rows and columns. Defaults to dist. |
| 21 | +#' @param hclustfun function used to compute the hierarchical clustering when Rowv or Colv are not dendrograms. Defaults to hclust. Should take as argument a result of distfun and return an object to which as.dendrogram can be applied. |
| 22 | +#' @param reorderfun function(d, w) of dendrogram and weights for reordering the row and column dendrograms. The default uses reorder.dendrogram. |
| 23 | +#' @param rowAnnotations Data frame of additional row annotations in same order as x (optional) |
| 24 | +#' @param columnAnnotations Data frame of additional column annotations in same order as x (optional) |
| 25 | +#' @param colorScheme List of scalingMode ("fixed" or "relative"), stepped (Whether color scheme is continuous (FALSE) or discrete (TRUE)), values (list of numbers corresponding to colors), colors (list of colors) |
| 26 | +#' @param rowSize Heat map column size in pixels or "fit" to fit heat map to current height (optional, defaults to 13) |
| 27 | +#' @param columnSize Heat map column size in pixels or "fit" to fit heat map to current width (optional, defaults to 13) |
| 28 | +#' @param drawGrid Whether to draw heat map grid (optional, defaults to \code{TRUE}) |
| 29 | +#' @param gridColor Heat map grid color (optional, defaults to "#808080") |
| 30 | +#' @param gridThickness Heat map grid thickness (optional, defaults to 0.1) |
| 31 | +#' @param drawValues Whether to draw values in the heat map (optional, defaults to \code{FALSE}) |
| 32 | +#' @param ... Additional morpheus options as documented at https://clue.io/morpheus/configuration.html |
| 33 | +#' |
| 34 | +#' @import htmlwidgets |
| 35 | +#' |
| 36 | +#' @export |
| 37 | +#' @source |
| 38 | +#' |
| 39 | +#' @seealso |
| 40 | +#' \link{heatmap} |
| 41 | +#' |
| 42 | +#' @examples |
| 43 | +#' library(morpheus) |
| 44 | +#' rowAnnotations = data.frame(1:32) |
| 45 | +#' morpheus(mtcars, rowAnnotations=rowAnnotations, colorScheme=list(values=list(0, 4), colors=list('green', 'black'))) |
| 46 | +#' |
| 47 | +morpheus <- function(x, |
| 48 | + labRow = rownames(x), |
| 49 | + labCol = colnames(x), |
| 50 | + Rowv = NULL, |
| 51 | + Colv = if(symm)"Rowv" else NULL, |
| 52 | + distfun = dist, |
| 53 | + hclustfun = hclust, |
| 54 | + reorderfun = function(d, w) reorder(d, w), |
| 55 | + rowAnnotations=NULL, |
| 56 | + columnAnnotations=NULL, |
| 57 | + symm = FALSE, |
| 58 | + na.rm = TRUE, |
| 59 | + width = NULL, height = NULL,... |
| 60 | +) { |
| 61 | + |
| 62 | + name <- deparse(substitute(x)) |
| 63 | + ## x is a matrix! |
| 64 | + if(!is.matrix(x)) { |
| 65 | + x <- as.matrix(x) |
| 66 | + } |
| 67 | + if(!is.matrix(x)) stop("x must be a matrix") |
| 68 | + |
| 69 | + nr <- dim(x)[1] |
| 70 | + nc <- dim(x)[2] |
| 71 | + ddc <- NULL |
| 72 | + ddr <- NULL |
| 73 | + doRdend <- !identical(Rowv, NA) |
| 74 | + doCdend <- !identical(Colv, NA) |
| 75 | + if (!doRdend && identical(Colv, "Rowv")) |
| 76 | + doCdend <- FALSE |
| 77 | + if (is.null(Rowv)) |
| 78 | + Rowv <- rowMeans(x, na.rm = na.rm) |
| 79 | + if (is.null(Colv)) |
| 80 | + Colv <- colMeans(x, na.rm = na.rm) |
| 81 | + if (doRdend) { |
| 82 | + if (inherits(Rowv, "dendrogram")) |
| 83 | + ddr <- Rowv |
| 84 | + else { |
| 85 | + hcr <- hclustfun(distfun(x)) |
| 86 | + ddr <- as.dendrogram(hcr) |
| 87 | + if (!is.logical(Rowv) || Rowv) |
| 88 | + ddr <- reorderfun(ddr, Rowv) |
| 89 | + } |
| 90 | + if (nr != length(rowInd <- order.dendrogram(ddr))) |
| 91 | + stop("row dendrogram ordering gave index of wrong length") |
| 92 | + } |
| 93 | + else rowInd <- 1L:nr |
| 94 | + if (doCdend) { |
| 95 | + if (inherits(Colv, "dendrogram")) |
| 96 | + ddc <- Colv |
| 97 | + else if (identical(Colv, "Rowv")) { |
| 98 | + if (nr != nc) |
| 99 | + stop("Colv = \"Rowv\" but nrow(x) != ncol(x)") |
| 100 | + ddc <- ddr |
| 101 | + } |
| 102 | + else { |
| 103 | + hcc <- hclustfun(distfun(if (symm) |
| 104 | + x |
| 105 | + else t(x))) |
| 106 | + ddc <- as.dendrogram(hcc) |
| 107 | + if (!is.logical(Colv) || Colv) |
| 108 | + ddc <- reorderfun(ddc, Colv) |
| 109 | + } |
| 110 | + if (nc != length(colInd <- order.dendrogram(ddc))) |
| 111 | + stop("column dendrogram ordering gave index of wrong length") |
| 112 | + } |
| 113 | + else colInd <- 1L:nc |
| 114 | + |
| 115 | + ddr <- rev(ddr) |
| 116 | + rowInd <- rev(rowInd) # reverse to match order of R heat maps |
| 117 | + x <- x[rowInd, colInd] |
| 118 | + |
| 119 | + ## Labels for Row/Column |
| 120 | + rownames(x) <- labRow %||% paste(1:nrow(x)) |
| 121 | + colnames(x) <- labCol %||% paste(1:ncol(x)) |
| 122 | + options(htmlwidgets.TOJSON_ARGS = list(dataframe="column")) |
| 123 | + options <- list(...) |
| 124 | + columnDendrogram <- if(!is.null(ddc) && is.dendrogram(ddc)) dendToTree(ddc) else NULL |
| 125 | + rowDendrogram <- if(!is.null(ddr) && is.dendrogram(ddr)) dendToTree(ddr) else NULL |
| 126 | + payload <- list(rows = nrow(x), rowDendrogram=rowDendrogram, columnDendrogram=columnDendrogram, columns = ncol(x), name=name, |
| 127 | + array=x, rowNames=rownames(x), columnNames=colnames(x), rowAnnotations=rowAnnotations, columnAnnotations=columnAnnotations, options = options) |
| 128 | + # create widget |
| 129 | + htmlwidgets::createWidget( |
| 130 | + name = 'morpheus', |
| 131 | + payload, |
| 132 | + width = width, |
| 133 | + height = height, |
| 134 | + package = 'morpheus', |
| 135 | + sizingPolicy = htmlwidgets::sizingPolicy(browser.fill = TRUE) |
| 136 | + ) |
| 137 | + |
| 138 | +} |
| 139 | + |
| 140 | + |
| 141 | + |
| 142 | +# Serialize a dendrogram object to a d3-friendly tree. The main |
| 143 | +# requirement is that nodes are lists with child nodes in a |
| 144 | +# field named `children`. |
| 145 | +dendToTree <- function(dend) { |
| 146 | + tree <- c( |
| 147 | + as.list(attributes(dend)[c('height')]) |
| 148 | + ) |
| 149 | + |
| 150 | + # Recursively add children |
| 151 | + if (!is.leaf(dend)) { |
| 152 | + tree$children <- lapply(dend, dendToTree) |
| 153 | + } |
| 154 | + tree |
| 155 | +} |
| 156 | + |
| 157 | +#' Shiny bindings for morpheus |
| 158 | +#' |
| 159 | +#' Output and render functions for using morpheus within Shiny |
| 160 | +#' applications and interactive Rmd documents. |
| 161 | +#' |
| 162 | +#' @param outputId output variable to read from |
| 163 | +#' @param width,height Must be a valid CSS unit (like \code{'100\%'}, |
| 164 | +#' \code{'400px'}, \code{'auto'}) or a number, which will be coerced to a |
| 165 | +#' string and have \code{'px'} appended. |
| 166 | +#' @param expr An expression that generates a morpheus |
| 167 | +#' @param env The environment in which to evaluate \code{expr}. |
| 168 | +#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This |
| 169 | +#' is useful if you want to save an expression in a variable. |
| 170 | +#' |
| 171 | +#' @name morpheus-shiny |
| 172 | +#' |
| 173 | +#' @export |
| 174 | +morpheusOutput <- function(outputId, width = '100%', height = '400px'){ |
| 175 | + htmlwidgets::shinyWidgetOutput(outputId, 'morpheus', width, height, package = 'morpheus') |
| 176 | +} |
| 177 | + |
| 178 | +#' @rdname morpheus-shiny |
| 179 | +#' @export |
| 180 | +renderMorpheus <- function(expr, env = parent.frame(), quoted = FALSE) { |
| 181 | + if (!quoted) { expr <- substitute(expr) } # force quoted |
| 182 | + htmlwidgets::shinyRenderWidget(expr, morpheusOutput, env, quoted = TRUE) |
| 183 | +} |
0 commit comments