Nothing
new_plots <- function(object,
name){
out <- new("IheatmapPlots")
out[[name]] <- object
out
}
new_axes <- function(object,
name,
axis = c("x","y")){
out <- new("IheatmapAxes",
axis = match.arg(axis))
out[[name]] <- object
out
}
new_colorbars <- function(object, name){
out <- new("IheatmapColorbars")
out[[name]] <- object
out
}
new_iheatmap <- function(plot,
xaxis,
yaxis,
pname = "Signal",
xname = "x",
yname = "y",
orientation = c("horizontal","vertical"),
colorbar_grid = setup_colorbar_grid(),
colorbar = NULL,
colorbar_name = NULL,
source = source,
layout = list(),
...){
orientation <- match.arg(orientation)
if (orientation == "horizontal"){
new("IheatmapHorizontal",
plots = new_plots(plot, pname),
xaxes = new_axes(xaxis, xname, axis = "x"),
yaxes = new_axes(yaxis, yname, axis = "y"),
colorbar_grid = colorbar_grid,
current_xaxis = xname,
current_yaxis = yname,
colorbars = new_colorbars(colorbar, colorbar_name),
source = source,
layout = modifyList(list(hovermode = 'closest',
margin = list(b = 50,
t = 50,
l = 50,
r= 50),
font = list()),
layout))
} else{
new("IheatmapVertical",
plots = new_plots(plot, pname),
xaxes = new_axes(xaxis, xname, axis = "x"),
yaxes = new_axes(yaxis, yname, axis = "y"),
colorbar_grid = colorbar_grid,
current_xaxis = xname,
current_yaxis = yname,
colorbars = new_colorbars(colorbar, colorbar_name),
source = source,
layout = modifyList(list(hovermode = 'closest',
margin = list(b = 50,
t = 50,
l = 50,
r= 50),
font = list()),
layout))
}
}
#' Tooltip Options
#'
#' This function setups tooltip options for heatmap components of iheatmapr
#' complex heatmaps.
#' @param row logical, include row name in tooltip?
#' @param col logical, include column name in tooltip?
#' @param value logical, include value in tooltip?
#' @param prepend_row text to prepend to row name
#' @param prepend_col text to prepend to column name
#' @param prepend_value text to prepend to value
#'
#' @return a HeatmapTooltipOptions object which stores these options and can be
#' passed to 'tooltip' argument to main_heatmap and other functions.
#' @export
#' @examples
#'
#' mat <- matrix(rnorm(20), ncol = 5, nrow = 4)
#' hm1 <- main_heatmap(mat,
#' tooltip = setup_tooltip_options(row = FALSE, col = FALSE,
#' prepend_value = "Value is "))
#'
#' # Print heatmap if interactive session
#' if (interactive()) hm1
setup_tooltip_options <- function(row = TRUE,
col = TRUE,
value = TRUE,
prepend_row = "Row: ",
prepend_col = "Col: ",
prepend_value = "Value: "){
new("HeatmapTooltipOptions",
row = row,
col = col,
value = value,
prepend_row = prepend_row,
prepend_col = prepend_col,
prepend_value = prepend_value)
}
#' main_heatmap
#'
#' Plots initial heatmap, creates Iheatmap object
#' @param data matrix
#' @param name name of colorbar
#' @param x x axis labels (by default rownames of data)
#' @param y y axis labels (by default colnames of data)
#' @param colors color palette or vector of colors
#' @param colorbar_grid colorbar grid parameters, should be result from
#' \code{\link{setup_colorbar_grid}}
#' @param colorbar_position colorbar placement, should be positive integer
#' @param zmin minimum for colorscale
#' @param zmax maximum for colorscale
#' @param zmid midpoint for colorscale
#' @param orientation should new main plots be added horizontally or vertically?
#' @param x_categorical is x categorical? will guess if not provided
#' @param y_categorical is y categorical? will guess if not provided
#' @param row_order row ordering for this heatmap-- will be used for all
#' subsequent elements sharing y axis
#' @param col_order column ordering for this heatmap-- will be used for all
#' subsequent elements sharing x axis
#' @param layout list of layout attributes to pass to plotly,
#' eg. list(font = list(size = 15))
#' @param xname internal name for xaxis
#' @param yname internal name for yaxis
#' @param pname internal plot name
#' @param source source name for use with shiny
#' @param show_colorbar logical to indicate whether to show colorbar
#' @param text text of value to display for data
#' @param tooltip tooltip options, see \code{\link{setup_tooltip_options}}
#'
#' @return \code{\link{Iheatmap-class}} object, which can be printed to generate
#' an interactive graphic
#' @seealso \code{\link{add_iheatmap}}, \code{\link{to_widget}},
#' \code{\link{iheatmap}}, \code{\link{Iheatmap-class}}
#' @export
#' @author Alicia Schep
#' @rdname main_heatmap
#' @name main_heatmap
#' @aliases main_heatmap,matrix-method
#' @examples
#'
#' mat <- matrix(rnorm(20), ncol = 5, nrow = 4)
#' hm <- main_heatmap(mat)
#'
#' # Print heatmap if interactive session
#' if (interactive()) hm
setMethod(main_heatmap, "matrix",
function(data,
name = "Signal",
x = default_x(data),
y = default_y(data),
colors = pick_continuous_colors(zmid, zmin, zmax),
colorbar_grid = setup_colorbar_grid(),
colorbar_position = 1,
zmid = 0,
zmin = min(data, na.rm = TRUE),
zmax = max(data, na.rm = TRUE),
orientation = c("horizontal", "vertical"),
x_categorical = NULL,
y_categorical = NULL,
row_order = seq_len(nrow(data)),
col_order = seq_len(ncol(data)),
text = signif(data, digits = 3),
tooltip = setup_tooltip_options(),
xname = "x",
yname = "y",
pname = name,
source = "iheatmapr",
show_colorbar = TRUE,
layout = list()){
iheatmap_argument_checks(data, row_order, col_order, x, y)
orientation <- match.arg(orientation)
if (is.null(x_categorical))
x_categorical <- is_categorical(x, col_order)
if (is.null(y_categorical))
y_categorical <- is_categorical(y, row_order)
new_plot <- new("MainHeatmap",
xaxis = "x",
yaxis = "y",
colorbar = name,
show_colorbar = show_colorbar,
data = data,
text = text,
tooltip = tooltip)
if (x_categorical){
xrange <- c(0.5,length(col_order)+0.5)
} else{
x <- as.numeric(x)
xdiff <- diff(sort(x))
xrange <- c(min(x) - xdiff[1] * 0.5,
max(x) + xdiff[length(xdiff)] * 0.5)
}
new_x <- new("IheatmapMainX",
id = "x",
domain_start = 0,
domain_end = 1,
categorical = x_categorical,
order = col_order,
text = x,
anchor = "y",
layout = list(ticks = "",
zeroline = FALSE,
showline = FALSE,
showgrid = FALSE,
showticklabels = FALSE,
range = xrange))
if (y_categorical){
yrange <- c(0.5,length(row_order)+0.5)
} else{
y <- as.numeric(y)
ydiff <- diff(sort(y))
yrange <- c(min(y) - (ydiff[1] * 0.5),
max(y) + (ydiff[length(ydiff)] * 0.5))
}
new_y <- new("IheatmapMainY",
id = "y",
domain_start = 0,
domain_end = 1,
categorical = y_categorical,
order = row_order,
text = y,
anchor = "x",
layout = list(ticks = "",
zeroline = FALSE,
showline = FALSE,
showgrid = FALSE,
showticklabels = FALSE,
range = yrange))
new_colorbar <- continuous_colorbar(name = name,
position = colorbar_position,
colors = colors,
zmid = zmid,
zmin = zmin,
zmax = zmax)
p <- new_iheatmap(plot = new_plot,
xaxis = new_x,
yaxis = new_y,
xname = xname,
yname = yname,
pname = pname,
orientation = orientation,
colorbar_grid = colorbar_grid,
colorbar = new_colorbar,
colorbar_name = name,
source = source,
layout = layout)
validObject(p)
p
})
#' add_main_heatmap
#'
#' Adds an additional main heatmap to an iheatmap object
#' @param p \code{\link{Iheatmap-class}} object
#' @param data matrix
#' @param name name of colorbar, will determine if colorbar is shared with
#' existing plot
#' @param x x axis labels (by default rownames of data); only used if
#' orientation is horizontal
#' @param y y axis labels (by default colnames of data); only used if
#' orientation is vertical
#' @param colors color palette name or vector of colors
#' @param colorbar_position colorbar placement
#' @param show_colorbar display the colorbar?
#' @param zmin minimum for colorscale
#' @param zmax maximum for colorscale
#' @param zmid midpoint for scale
#' @param x_categorical is x categorical? will guess if not provided
#' @param y_categorical is y categorical? will guess if not provided
#' @param col_order column ordering for this heatmap; only used if orientation
#' is horizontal
#' @param row_order row ordering for this heatmap; only used if orientation is
#' vertical
#' @param side which side of the current plot to add this heatmap?
#' @param size relative size of plot. size relative to first heatmap
#' @param buffer amount of space to leave empty before this plot, relative to
#' size of first heatmap
#' @param xname internal name for x axis
#' @param yname internal name for y axis
#' @param pname internal name for plot
#' @param text text of value to display for data
#' @param tooltip tooltip options, see \code{\link{setup_tooltip_options}}
#' @param ... additional arguments (ignored)
#'
#' @seealso \code{\link{iheatmap}}, \code{\link{main_heatmap}}
#' @return \code{\link{Iheatmap-class}} object, which can be printed to generate
#' an interactive graphic
#' @export
#' @author Alicia Schep
#' @rdname add_main_heatmap
#' @name add_main_heatmap
#' @aliases add_main_heatmap,IheatmapHorizontal,matrix-method
#' add_main_heatmap,IheatmapVertical,matrix-method
#' @examples
#'
#' mat <- matrix(rnorm(20), ncol = 5, nrow = 4)
#' mat2 <- matrix(rnorm(24), ncol = 6, nrow = 4)
#' hm <- iheatmap(mat) %>% add_main_heatmap(mat2)
#'
#' # Print heatmap if interactive session
#' if (interactive()) hm
setMethod("add_main_heatmap", c(p = "IheatmapHorizontal", data = "matrix"),
function(p,
data,
name = "Signal",
x = default_x(data),
colors = pick_continuous_colors(zmid,zmin,zmax, p),
colorbar_position = get_colorbar_position(p),
show_colorbar = TRUE,
zmin = min(data, na.rm = TRUE),
zmax = max(data, na.rm = TRUE),
zmid = 0,
col_order = NULL,
x_categorical = NULL,
side = c("right","left"),
size = 1,
buffer = 0.04,
text = signif(data, digits = 3),
tooltip = setup_tooltip_options(),
xname = NULL,
pname = name,
...){
side <- match.arg(side)
additional_ags <- list(...)
if (is.null(col_order)) col_order <- seq_len(ncol(data))
if (is.null(x_categorical))
x_categorical <- is_categorical(x, col_order)
stopifnot(is.logical(x_categorical))
if (x_categorical){
xrange <- c(0.5,length(col_order)+0.5)
} else{
x <- as.numeric(x)
xdiff <- diff(sort(x))
xrange <- c(min(x) - (xdiff[1] * 0.5),
max(x) + (xdiff[length(xdiff)] * 0.5))
}
new_x <-
new("IheatmapMainX",
id = paste0("x", length(xaxes(p)) + 1),
domain_start = 0,
domain_end = 1,
categorical = x_categorical,
order = as.integer(col_order),
text = x,
anchor = "y",
layout = list(ticks = "",
zeroline = FALSE,
showline = FALSE,
showgrid = FALSE,
showticklabels = FALSE,
range = xrange))
if (is.null(xname)) xname <- id(new_x)
current_xaxis(p) <- xname
new_plot <- new("MainHeatmap",
xaxis = xname,
yaxis = "y",
colorbar = name,
show_colorbar = show_colorbar,
data = data,
text = text,
tooltip = tooltip)
new_colorbar <- continuous_colorbar(name, colorbar_position,
colors, zmid, zmin, zmax)
p <- add_axis(p, new_x, xname, size, buffer, side)
p <- add_plot(p, new_plot, pname)
p <- add_colorbar(p, new_colorbar)
validObject(p)
p
})
#' @rdname add_main_heatmap
#' @export
setMethod("add_main_heatmap", c(p = "IheatmapVertical", data = "matrix"),
function(p,
data,
name = "Signal",
y = default_y(data),
colors = pick_continuous_colors(zmid,zmin,zmax, p),
colorbar_position = get_colorbar_position(p),
show_colorbar = TRUE,
zmin = min(data, na.rm = TRUE),
zmax = max(data, na.rm = TRUE),
zmid = 0,
row_order = NULL,
y_categorical = NULL,
side = c("bottom","top"),
size = 1,
buffer = 0.04,
text = signif(data, digits = 3),
tooltip = setup_tooltip_options(),
yname = NULL,
pname = name,
...){
side <- match.arg(side)
if (is.null(row_order)) row_order <- seq_len(nrow(data))
if (is.null(y_categorical))
y_categorical <- is_categorical(y, row_order)
stopifnot(is.logical(y_categorical))
if (y_categorical){
yrange <- c(0.5,length(row_order)+0.5)
} else{
y <- as.numeric(y)
ydiff <- diff(sort(y))
yrange <- c(min(y) - (ydiff[1] * 0.5),
max(y) + (ydiff[length(ydiff)] * 0.5))
}
new_y <-
new("IheatmapMainY",
id = paste0("y", length(yaxes(p)) + 1),
domain_start = 0,
domain_end = 1,
categorical = y_categorical,
order = as.integer(row_order),
text = y,
anchor = "x",
layout = list(ticks = "",
zeroline = FALSE,
showline = FALSE,
showgrid = FALSE,
showticklabels = FALSE,
range = yrange))
if (is.null(yname)) yname <- id(new_y)
current_yaxis(p) <- yname
new_plot <- new("MainHeatmap",
xaxis = "x",
yaxis = yname,
colorbar = name,
show_colorbar = show_colorbar,
data = data,
text = text,
tooltip = tooltip)
new_colorbar <- continuous_colorbar(name, colorbar_position,
colors, zmid, zmin, zmax)
p <- add_axis(p, new_y, yname, size, buffer, side)
p <- add_plot(p, new_plot, pname)
p <- add_colorbar(p, new_colorbar)
validObject(p)
p
})
setMethod("make_trace", signature = c(x = "MainHeatmap"),
function(x, xaxes, yaxes, colorbars, colorbar_grid, ...){
cb <- colorbars[[x@colorbar]]
xa <- xaxes[[xaxis_name(x)]]
ya <- yaxes[[yaxis_name(x)]]
txt <- make_text_matrix(x@text, axis_text(xa), axis_text(ya),
axis_order(ya), axis_order(xa), x@tooltip)
colorscale <- colorscale(cb, get_data(x))
out <- list(z = I(get_data(x)[axis_order(ya),
axis_order(xa),
drop = FALSE]),
x = I(axis_values(xa)),
y = I(axis_values(ya)),
type="heatmap",
text = I(txt),
colorscale = colorscale,
xaxis = id(xa),
yaxis = id(ya),
zmin = cb@zmin,
zmax = cb@zmax,
hoverinfo = "text",
showscale = x@show_colorbar,
colorbar = make_colorbar(cb, colorbar_grid))
return(out)
})
make_text_matrix <- function(mat, x, y, row_order, col_order, tooltip){
if (tooltip@row & tooltip@col){
txt <- outer(paste0(tooltip@prepend_row, y[row_order]),
paste0(tooltip@prepend_col, x[col_order]),
FUN = paste, sep = "<br>")
} else if (tooltip@row){
txt <- outer(paste0(tooltip@prepend_row, y[row_order]),
rep("", length(col_order)),
FUN = paste0)
} else if (tooltip@col){
txt <- outer(rep("", length(row_order)),
paste0(tooltip@prepend_col, x[col_order]),
FUN = paste0)
} else if (tooltip@value){
txt <- matrix(paste0(tooltip@prepend_value, mat[row_order, col_order]),
nrow = length(row_order), ncol = length(col_order))
return(txt)
} else{
txt <- outer(rep("", length(row_order)),
rep("", length(col_order)),
FUN = paste0)
return(txt)
}
if (tooltip@value){
txt <- matrix(paste(txt, paste0(tooltip@prepend_value, mat[row_order, col_order]),
sep = "<br>"),
nrow = length(row_order), ncol = length(col_order))
}
return(txt)
}
iheatmap_argument_checks <- function(mat, row_order, col_order, x, y){
if (!inherits(mat,"matrix")) stop("data must be a matrix!")
if (any(row_order %ni% seq_len(nrow(mat))))
stop("Row order contains invalid indices")
if (any(col_order %ni% seq_len(ncol(mat))))
stop("Col order contains invalid indices")
if (length(y) != nrow(mat))
stop("y does not match number of rows of matrix")
if (length(x) != ncol(mat))
stop("x does not match number of columns of matrix")
return(TRUE)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.