Nothing
R/axes.R
In iheatmapr: Interactive, Complex Heatmaps
Defines functions
one_bounded
zero_bounded
new_yaxis
new_xaxis
#' reorder_rows
#'
#' Reorder the rows of an \code{\link{Iheatmap-class}} object
#' @param p \code{\link{Iheatmap-class}} object
#' @param row_order integer vector
#' @param yname name of yaxis to reorder, only applicable if object is oriented
#' vertically
#' @seealso \code{\link{add_row_clustering}}, \code{\link{reorder_cols}}
#' @return \code{\link{Iheatmap-class}} object, which can be printed to generate
#' an interactive graphic
#' @export
#' @author Alicia Schep
#' @rdname reorder_rows
#' @name reorder_rows
#' @aliases reorder_rows,IheatmapHorizontal,integer-method
#' reorder_rows,IheatmapVertical,integer-method
#' @examples
#'
#' mat <- matrix(rnorm(20), ncol = 5, nrow = 4)
#' dend <- hclust(dist(mat))
#' hm <- iheatmap(mat) %>% reorder_rows(dend$order)
#'
#' # Print heatmap if interactive session
#' if (interactive()) hm
setMethod(reorder_rows, c(p = "IheatmapHorizontal", row_order = "integer"),
function(p, row_order){
stopifnot(yaxes(p)[["y"]]@categorical)
axis_order(yaxes(p)[["y"]]) <- row_order
validObject(p)
p
})
#' @rdname reorder_rows
setMethod(reorder_rows, c(p = "IheatmapVertical", row_order = "integer"),
function(p, row_order, yname = current_yaxis(p)){
stopifnot(yaxes(p)[[yname]]@categorical)
axis_order(yaxes(p)[[yname]]) <- row_order
p
})
#' reorder_cols
#'
#' Reorder the columns of an \code{\link{Iheatmap-class}} object
#' @param p \code{\link{Iheatmap-class}} object
#' @param col_order integer vector
#' @param xname name of xaxis to reorder, only applicable if object is oriented
#' horizontally
#' @seealso \code{\link{add_row_clustering}}, \code{\link{reorder_cols}}
#' @return \code{\link{Iheatmap-class}} object, which can be printed to generate
#' an interactive graphic
#' @export
#' @author Alicia Schep
#' @rdname reorder_cols
#' @name reorder_cols
#' @aliases reorder_cols,IheatmapHorizontal,integer-method
#' reorder_cols,IheatmapVertical,integer-method
#' @examples
#'
#' mat <- matrix(rnorm(20), ncol = 5, nrow = 4)
#' dend <- hclust(dist(t(mat)))
#' hm <- iheatmap(mat) %>% reorder_cols(dend$order)
#'
#' # Print heatmap if interactive session
#' if (interactive()) hm
setMethod(reorder_cols, c(p = "IheatmapHorizontal", col_order = "integer"),
function(p, col_order, xname = current_xaxis(p)){
stopifnot(xaxes(p)[[xname]]@categorical)
axis_order(xaxes(p)[[xname]]) <- col_order
p
})
#' @rdname reorder_cols
#' @export
setMethod(reorder_cols, c(p = "IheatmapVertical", col_order = "integer"),
function(p, col_order){
stopifnot(xaxes(p)[["x"]]@categorical)
axis_order(xaxes(p)[["x"]]) <- col_order
p
})
new_xaxis <- function(p, yname, layout = list()){
if (yname %ni% names(yaxes(p)))
stop("Invalid yname argument")
new("IheatmapX",
id = paste0("x", length(xaxes(p)) + 1),
domain_start = 0,
domain_end = 1,
anchor = id(yaxes(p)[[yname]]),
layout = layout)
}
new_yaxis <- function(p, xname, layout = list()){
if (xname %ni% names(xaxes(p)))
stop("Invalid xname argument")
new("IheatmapY",
id = paste0("y", length(yaxes(p)) + 1),
domain_start = 0,
domain_end = 1,
anchor = id(xaxes(p)[[xname]]),
layout = layout)
}
zero_bounded <- function(x){
if (abs(x) < 10**-10){
out <- 0
} else if (x >= 0){
out <- x
} else{
stop("Value should be positive")
}
return(out)
}
one_bounded <- function(x){
if (abs(x - 1) < 10**-10){
out <- 1
} else if (x <= 1){
out <- x
} else{
stop("Value should be less than 1")
}
return(out)
}
no_axis <- list(title = "",
zeroline = FALSE,
showline = FALSE,
showticklabels = FALSE,
showgrid = FALSE,
ticks = "")
setMethod(current_xaxis, c(x = "Iheatmap"),
function(x){x@current_xaxis})
setReplaceMethod("current_xaxis", c(x = "IheatmapHorizontal"),
function(x, value){x@current_xaxis <- value; x})
setMethod(current_yaxis, c(x = "Iheatmap"),
function(x){x@current_yaxis})
setReplaceMethod("current_yaxis", c(x = "IheatmapVertical"),
function(x, value){x@current_yaxis <- value; x})
setMethod(axis_text, c(x = "IheatmapMainAxis"),
function(x, ordered = FALSE){
if (x@categorical){
if (ordered){
return(as.character(x@text[x@order]))
} else{
return(as.character(x@text))
}
} else{
return(as.character(x@text))
}
})
setMethod(axis_values, c(x = "IheatmapMainAxis"),
function(x, ordered = FALSE){
if (x@categorical){
vals <- seq_along(x@text)
if (ordered){
return(vals[x@order])
} else{
return(vals)
}
} else{
return(as.numeric(x@text))
}
})
setMethod(axis_order, c(x = "IheatmapMainAxis"),
function(x){x@order})
setMethod(domain_start, c(x = "IheatmapAxis"),
function(x){x@domain_start})
setMethod(domain_start, c(x = "IheatmapAxes"),
function(x){vapply(x, domain_start, 1)})
setReplaceMethod("domain_start", c(x = "IheatmapAxis"),
function(x, value){x@domain_start <- value; x})
setReplaceMethod("domain_start", c(x = "IheatmapAxes"),
function(x, value){
for (i in seq_along(x)){
x[[i]]@domain_start <- value[i]
}
x})
setMethod('sort', c(x = "IheatmapAxes"),
function(x, decreasing = FALSE){
ix <- order(domain_start(x), decreasing = decreasing)
x[ix]
})
setMethod(domain_end, c(x = "IheatmapAxis"),
function(x){x@domain_end})
setMethod(domain_end, c(x = "IheatmapAxes"),
function(x){vapply(x, domain_end, 1)})
setReplaceMethod("domain_end", c(x = "IheatmapAxis"),
function(x, value){x@domain_end <- value; x})
setReplaceMethod("domain_end", c(x = "IheatmapAxes"),
function(x, value){
for (i in seq_along(x)){
x[[i]]@domain_end <- value[i]
}
x})
setMethod(id, c(x = "IheatmapAxis"),
function(x){x@id})
setMethod(id, c(x = "IheatmapAxes"),
function(x){vapply(x, id, "")})
setMethod(xaxis_name, c(x = "IheatmapPanel"),
function(x){x@xaxis})
setMethod(xaxis_name, c(x = "IheatmapPanels"),
function(x){vapply(x, xaxis_name,"")})
setMethod(xaxis_name, c(x = "Iheatmap"),
function(x){
unlist(c(xaxis_name(x@plots),
xaxis_name(x@shapes),
xaxis_name(x@annotations)))})
setMethod(yaxis_name, c(x = "IheatmapPanel"),
function(x){x@yaxis})
setMethod(yaxis_name, c(x = "IheatmapPanels"),
function(x){vapply(x, yaxis_name, "")})
setMethod(yaxis_name, c(x = "Iheatmap"),
function(x){
unlist(c(yaxis_name(x@plots),
yaxis_name(x@shapes),
yaxis_name(x@annotations)))})
setMethod('buffers', c(x = "IheatmapAxes"),
function(x){
stopifnot(identical(x, sort(x)))
if (length(x) > 1) domain_start(x)[2:length(x)] -
domain_end(x)[1:(length(x) - 1)] else c()
})
setReplaceMethod("axis_order", c("IheatmapMainAxis"),
function(x, value){
if (x@categorical){
x@order <- value
return(x)
} else{
stop("Cannot reorder continuous axis!")
}
})
setMethod(add_axis, c(p = "IheatmapHorizontal", new_axis = "IheatmapX"),
function(p,
new_axis,
xname,
size = 1,
buffer = 0.04,
side = c("left","right"),
...){
side <- match.arg(side)
axes <- sort(xaxes(p))
if (xname %in% names(axes)){
return(p)
}
ids <- id(axes)
main_ix <- which(ids == "x")
starts <- unname(domain_start(axes))
ends <- unname(domain_end(axes))
sizes <- ends - starts
main_size <- sizes[main_ix]
new_size <- main_size * size
buffer_sizes <- c(unname(buffers(axes)), buffer * main_size)
norm_factor <- sum(sizes) + sum(buffer_sizes) + new_size
new_size <- new_size / norm_factor
buffer_sizes <- buffer_sizes / norm_factor
sizes <- sizes / norm_factor
if (side == "right"){
domain_start(axes) <- starts / norm_factor
domain_end(axes) <- ends / norm_factor
domain_start(new_axis) <- 1 - new_size
domain_end(new_axis) <- 1
axes[[xname]] <- new_axis
} else{
domain_start(axes) <- 1 - ((1 - starts) / norm_factor)
domain_end(axes) <- 1 - ((1 - ends) / norm_factor)
domain_start(new_axis) <- 0
domain_end(new_axis) <- new_size
axes[[xname]] <- new_axis
}
p@xaxes <- axes
return(p)
})
setMethod(add_axis, c(p = "IheatmapHorizontal", new_axis = "IheatmapY"),
function(p,
new_axis,
yname,
xname,
size = 1,
buffer = 0.04,
side = c("top","bottom")){
side <- match.arg(side)
if (yname %in% names(yaxes(p))){
if (yname %in% names(yaxes(p, xname))){
return(p)
} else{
existing <- TRUE
}
} else{
existing <- FALSE
}
axes <- yaxes(p)
current <- sort(yaxes(p, xname))
ids <- id(current)
main_ix <- which(ids == "y")
starts <- unname(domain_start(current))
ends <- unname(domain_end(current))
sizes <- ends - starts
main_size <- sizes[main_ix]
if (existing){
existing_start <- domain_start(yaxes(p)[[yname]])
existing_end <- domain_end(yaxes(p)[[yname]])
new_size <- existing_end - existing_start
other_x <- names(xaxes(p, yname))
y_for_other_x <- sort(yaxes(p, other_x[[1]]))
if (side == "top" && existing_start < ends[main_ix])
stop("Mismatch between side and existing yname")
if (side == "bottom" && existing_start > starts[main_ix])
stop("Mismatch between side and existing yname")
y_ix <- which(names(y_for_other_x) == yname)
new_buffer_size <- if (side == "top"){
domain_start(y_for_other_x[y_ix]) -
domain_end(y_for_other_x[y_ix - 1])
} else{
domain_start(y_for_other_x[y_ix + 1]) -
domain_end(y_for_other_x[y_ix])
}
} else{
new_size <- main_size * size
new_buffer_size <- buffer * main_size
}
buffer_sizes <- unname(buffers(current))
if (side == "top"){
if (existing){
resize <- existing_start < (max(ends) + new_buffer_size)
} else{
needed_room <- new_size + new_buffer_size
available_room <- 1 - max(ends)
resize <- needed_room > available_room
}
if (resize){
#need to adjust sizes
if (existing){
norm_factor <- sum(sizes) + sum(buffer_sizes) + new_size +
new_buffer_size + min(starts) + (1-existing_end)
} else{
norm_factor <- sum(sizes) + sum(buffer_sizes) + new_size +
new_buffer_size + min(starts)
}
sizes <- sizes / norm_factor
buffer_sizes <- c(buffer_sizes, new_buffer_size) / norm_factor
new_size <- new_size / norm_factor
j <- min(starts) / norm_factor
for (i in seq_along(sizes)){
domain_start(axes[[names(current)[i]]]) <- j
domain_end(axes[[names(current)[i]]]) <- j + sizes[i]
j <- j + sizes[i] + buffer_sizes[i]
}
if (existing){
domain_start(axes[[yname]]) <- j
domain_end(axes[[yname]]) <- one_bounded(j + new_size)
} else{
domain_start(new_axis) <- j
domain_end(new_axis) <- one_bounded(j + new_size)
axes[[yname]] <- new_axis
}
} else{
if (!existing){
domain_start(new_axis) <- max(ends) + new_buffer_size
domain_end(new_axis) <- one_bounded(max(ends) +
new_buffer_size +
new_size)
axes[[yname]] <- new_axis
}
}
} else if (side == "bottom"){
if (existing){
resize <- existing_end > (min(starts) - new_buffer_size)
} else{
needed_room <- new_size + new_buffer_size
available_room <- min(starts)
resize <- needed_room > available_room
}
if (resize){
#need to adjust sizes
if (existing){
norm_factor <- sum(sizes) + sum(buffer_sizes) +
new_size + new_buffer_size + (1 - max(ends)) +
existing_start
} else{
norm_factor <- sum(sizes) + sum(buffer_sizes) +
new_size + new_buffer_size + (1 - max(ends))
}
sizes <- sizes / norm_factor
buffer_sizes <- c(new_buffer_size, buffer_sizes) / norm_factor
new_buffer_size <- new_buffer_size / norm_factor
new_size <- new_size / norm_factor
j <- 1 - ((1 - (max(ends))) / norm_factor)
for (i in rev(seq_along(sizes))){
domain_start(axes[[names(current)[i]]]) <- j - sizes[i]
domain_end(axes[[names(current)[i]]]) <- j
j <- j - sizes[i] - buffer_sizes[i]
}
if (existing){
domain_start(axes[[yname]]) <- zero_bounded(j - new_size)
domain_end(axes[[yname]]) <- j
} else{
domain_start(new_axis) <- zero_bounded(j - new_size)
domain_end(new_axis) <- j
axes[[yname]] <- new_axis
}
} else{
if (!existing){
domain_start(new_axis) <- zero_bounded(min(starts) -
new_buffer_size -
new_size)
domain_end(new_axis) <- min(starts) - new_buffer_size
axes[[yname]] <- new_axis
}
}
}
if (resize){
#Adjust additional y axes as well
additional_x_axes <- xaxes(p)[names(xaxes(p)) != xname]
for (k in names(additional_x_axes)){
additional <- sort(yaxes(p, k))
if (length(additional) >= 2){
additional_starts <- unname(domain_start(additional))
additional_ends <- unname(domain_end(additional))
additional_sizes <- (additional_ends - additional_starts) /
norm_factor
additional_buffer_sizes <- c(unname(buffers(additional)),0) /
norm_factor
new_ybottom <- domain_start(axes[[which(id(axes) == "y")]])
old_ybottom <- domain_start(yaxes(p)[[which(id(yaxes(p)) ==
"y")]])
old_bottom <- min(additional_starts)
j <- zero_bounded(new_ybottom - ((old_ybottom - old_bottom) /
norm_factor))
for (i in seq_along(additional_sizes)){
if (names(additional)[i] %ni% c(yname,names(current))){
domain_start(axes[[names(additional)[i]]]) <- j
domain_end(axes[[names(additional)[i]]]) <-
one_bounded(j + additional_sizes[i])
j <- j + additional_sizes[i] + additional_buffer_sizes[i]
} else{
j <- domain_end(axes[[names(additional)[i]]]) +
additional_buffer_sizes[i]
}
}
}
}
}
p@yaxes <- axes
return(p)
})
setMethod(add_axis, c(p = "IheatmapVertical", new_axis = "IheatmapY"),
function(p,
new_axis,
yname,
size = 1,
buffer = 0.04,
side = c("top","bottom"),
...){
side <- match.arg(side)
axes <- sort(yaxes(p))
if (yname %in% names(axes)){
return(p)
}
ids <- id(axes)
main_ix <- which(ids == "y")
starts <- unname(domain_start(axes))
ends <- unname(domain_end(axes))
sizes <- ends - starts
main_size <- sizes[main_ix]
new_size <- main_size * size
buffer_sizes <- c(unname(buffers(axes)), buffer * main_size)
norm_factor <- sum(sizes) + sum(buffer_sizes) + new_size
new_size <- new_size / norm_factor
buffer_sizes <- buffer_sizes / norm_factor
sizes <- sizes / norm_factor
if (side == "top"){
domain_start(axes) <- starts / norm_factor
domain_end(axes) <- ends / norm_factor
domain_start(new_axis) <- 1 - new_size
domain_end(new_axis) <- 1
axes[[yname]] <- new_axis
} else{
domain_start(axes) <- 1 - ((1 - starts) / norm_factor)
domain_end(axes) <- 1 - ((1 - ends) / norm_factor)
domain_start(new_axis) <- 0
domain_end(new_axis) <- new_size
axes[[yname]] <- new_axis
}
p@yaxes <- axes
return(p)
})
setMethod(add_axis, c(p = "IheatmapVertical", new_axis = "IheatmapX"),
function(p,
new_axis,
xname,
yname,
size = 1,
buffer = 0.04,
side = c("right","left")){
side <- match.arg(side)
if (xname %in% names(xaxes(p))){
if (xname %in% names(xaxes(p, yname))){
return(p)
} else{
existing <- TRUE
}
} else{
existing <- FALSE
}
axes <- xaxes(p)
current <- sort(xaxes(p, yname))
ids <- id(current)
main_ix <- which(ids == "x")
starts <- unname(domain_start(current))
ends <- unname(domain_end(current))
sizes <- ends - starts
main_size <- sizes[main_ix]
if (existing){
existing_start <- domain_start(xaxes(p)[[xname]])
existing_end <- domain_end(xaxes(p)[[xname]])
new_size <- existing_end - existing_start
other_y <- names(yaxes(p, xname))
x_for_other_y <- sort(xaxes(p, other_y[[1]]))
if (side == "right" && existing_start < ends[main_ix])
stop("Mismatch between side and existing x axis with xname")
if (side == "left" && existing_start > starts[main_ix])
stop("Mismatch between side and existing x axis with xname")
x_ix <- which(names(x_for_other_y) == xname)
new_buffer_size <- if (side == "top"){
domain_start(x_for_other_y[x_ix]) -
domain_end(x_for_other_y[x_ix - 1])
} else{
domain_start(x_for_other_y[x_ix + 1]) -
domain_end(x_for_other_y[x_ix])
}
} else{
new_size <- main_size * size
new_buffer_size <- buffer * main_size
}
buffer_sizes <- unname(buffers(current))
if (side == "right"){
if (existing){
resize <- existing_start < (max(ends) + new_buffer_size)
} else{
needed_room <- new_size + new_buffer_size
available_room <- 1 - max(ends)
resize <- needed_room > available_room
}
if (resize){
#need to adjust sizes
if (existing){
norm_factor <- sum(sizes) + sum(buffer_sizes) + new_size +
new_buffer_size + min(starts) + (1-existing_end)
} else{
norm_factor <- sum(sizes) + sum(buffer_sizes) + new_size +
new_buffer_size + min(starts)
}
sizes <- sizes / norm_factor
buffer_sizes <- c(buffer_sizes, new_buffer_size) / norm_factor
new_size <- new_size / norm_factor
j <- min(starts) / norm_factor
for (i in seq_along(sizes)){
domain_start(axes[[names(current)[i]]]) <- j
domain_end(axes[[names(current)[i]]]) <- j + sizes[i]
j <- j + sizes[i] + buffer_sizes[i]
}
if (existing){
domain_start(axes[[xname]]) <- j
domain_end(axes[[xname]]) <- one_bounded(j + new_size)
} else{
domain_start(new_axis) <- j
domain_end(new_axis) <- one_bounded(j + new_size)
axes[[xname]] <- new_axis
}
} else{
if (!existing){
domain_start(new_axis) <- max(ends) + new_buffer_size
domain_end(new_axis) <- one_bounded(max(ends) +
new_buffer_size +
new_size)
axes[[xname]] <- new_axis
}
}
} else if (side == "left"){
if (existing){
resize <- existing_end > (min(starts) - new_buffer_size)
} else{
needed_room <- new_size + new_buffer_size
available_room <- min(starts)
resize <- needed_room > available_room
}
if (resize){
#need to adjust sizes
if (existing){
norm_factor <- sum(sizes) + sum(buffer_sizes) +
new_size + new_buffer_size + (1 - max(ends)) +
existing_start
} else{
norm_factor <- sum(sizes) + sum(buffer_sizes) +
new_size + new_buffer_size + (1 - max(ends))
}
sizes <- sizes / norm_factor
buffer_sizes <- c(new_buffer_size, buffer_sizes) / norm_factor
new_buffer_size <- new_buffer_size / norm_factor
new_size <- new_size / norm_factor
j <- 1 - ((1 - (max(ends))) / norm_factor)
for (i in rev(seq_along(sizes))){
domain_start(axes[[names(current)[i]]]) <- j - sizes[i]
domain_end(axes[[names(current)[i]]]) <- j
j <- j - sizes[i] - buffer_sizes[i]
}
if (existing){
domain_start(axes[[xname]]) <- zero_bounded(j - new_size)
domain_end(axes[[xname]]) <- j
} else{
domain_start(new_axis) <- zero_bounded(j - new_size)
domain_end(new_axis) <- j
axes[[xname]] <- new_axis
}
} else{
if (!existing){
domain_start(new_axis) <- zero_bounded(min(starts) -
new_buffer_size -
new_size)
domain_end(new_axis) <- min(starts) - new_buffer_size
axes[[xname]] <- new_axis
}
}
}
if (resize){
#Adjust additional y axes as well
additional_y_axes <- yaxes(p)[names(yaxes(p)) != yname]
for (k in names(additional_y_axes)){
additional <- sort(xaxes(p, k))
if (length(additional) >= 2){
additional_starts <- unname(domain_start(additional))
additional_ends <- unname(domain_end(additional))
additional_sizes <- (additional_ends - additional_starts) /
norm_factor
additional_buffer_sizes <- c(unname(buffers(additional)),0) /
norm_factor
new_xbottom <- domain_start(axes[[which(id(axes) == "x")]])
old_xbottom <- domain_start(xaxes(p)[[which(id(xaxes(p)) ==
"x")]])
old_bottom <- min(additional_starts)
j <- zero_bounded(new_xbottom - ((old_xbottom - old_bottom) /
norm_factor))
for (i in seq_along(additional_sizes)){
if (names(additional)[i] %ni% c(xname,names(current))){
domain_start(axes[[names(additional)[i]]]) <- j
domain_end(axes[[names(additional)[i]]]) <-
one_bounded(j + additional_sizes[i])
j <- j + additional_sizes[i] + additional_buffer_sizes[i]
} else{
j <- domain_end(axes[[names(additional)[i]]]) +
additional_buffer_sizes[i]
}
}
}
}
}
p@xaxes <- axes
return(p)
})
Try the iheatmapr package in your browser
Any scripts or data that you put into this service are public.
iheatmapr documentation built on May 29, 2024, 8:55 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions one_bounded zero_bounded new_yaxis new_xaxis
#' reorder_rows
#'
#' Reorder the rows of an \code{\link{Iheatmap-class}} object
#' @param p \code{\link{Iheatmap-class}} object
#' @param row_order integer vector
#' @param yname name of yaxis to reorder, only applicable if object is oriented
#' vertically
#' @seealso \code{\link{add_row_clustering}}, \code{\link{reorder_cols}}
#' @return \code{\link{Iheatmap-class}} object, which can be printed to generate
#' an interactive graphic
#' @export
#' @author Alicia Schep
#' @rdname reorder_rows
#' @name reorder_rows
#' @aliases reorder_rows,IheatmapHorizontal,integer-method
#' reorder_rows,IheatmapVertical,integer-method
#' @examples
#'
#' mat <- matrix(rnorm(20), ncol = 5, nrow = 4)
#' dend <- hclust(dist(mat))
#' hm <- iheatmap(mat) %>% reorder_rows(dend$order)
#'
#' # Print heatmap if interactive session
#' if (interactive()) hm
setMethod(reorder_rows, c(p = "IheatmapHorizontal", row_order = "integer"),
function(p, row_order){
stopifnot(yaxes(p)[["y"]]@categorical)
axis_order(yaxes(p)[["y"]]) <- row_order
validObject(p)
p
})
#' @rdname reorder_rows
setMethod(reorder_rows, c(p = "IheatmapVertical", row_order = "integer"),
function(p, row_order, yname = current_yaxis(p)){
stopifnot(yaxes(p)[[yname]]@categorical)
axis_order(yaxes(p)[[yname]]) <- row_order
p
})
#' reorder_cols
#'
#' Reorder the columns of an \code{\link{Iheatmap-class}} object
#' @param p \code{\link{Iheatmap-class}} object
#' @param col_order integer vector
#' @param xname name of xaxis to reorder, only applicable if object is oriented
#' horizontally
#' @seealso \code{\link{add_row_clustering}}, \code{\link{reorder_cols}}
#' @return \code{\link{Iheatmap-class}} object, which can be printed to generate
#' an interactive graphic
#' @export
#' @author Alicia Schep
#' @rdname reorder_cols
#' @name reorder_cols
#' @aliases reorder_cols,IheatmapHorizontal,integer-method
#' reorder_cols,IheatmapVertical,integer-method
#' @examples
#'
#' mat <- matrix(rnorm(20), ncol = 5, nrow = 4)
#' dend <- hclust(dist(t(mat)))
#' hm <- iheatmap(mat) %>% reorder_cols(dend$order)
#'
#' # Print heatmap if interactive session
#' if (interactive()) hm
setMethod(reorder_cols, c(p = "IheatmapHorizontal", col_order = "integer"),
function(p, col_order, xname = current_xaxis(p)){
stopifnot(xaxes(p)[[xname]]@categorical)
axis_order(xaxes(p)[[xname]]) <- col_order
p
})
#' @rdname reorder_cols
#' @export
setMethod(reorder_cols, c(p = "IheatmapVertical", col_order = "integer"),
function(p, col_order){
stopifnot(xaxes(p)[["x"]]@categorical)
axis_order(xaxes(p)[["x"]]) <- col_order
p
})
new_xaxis <- function(p, yname, layout = list()){
if (yname %ni% names(yaxes(p)))
stop("Invalid yname argument")
new("IheatmapX",
id = paste0("x", length(xaxes(p)) + 1),
domain_start = 0,
domain_end = 1,
anchor = id(yaxes(p)[[yname]]),
layout = layout)
}
new_yaxis <- function(p, xname, layout = list()){
if (xname %ni% names(xaxes(p)))
stop("Invalid xname argument")
new("IheatmapY",
id = paste0("y", length(yaxes(p)) + 1),
domain_start = 0,
domain_end = 1,
anchor = id(xaxes(p)[[xname]]),
layout = layout)
}
zero_bounded <- function(x){
if (abs(x) < 10**-10){
out <- 0
} else if (x >= 0){
out <- x
} else{
stop("Value should be positive")
}
return(out)
}
one_bounded <- function(x){
if (abs(x - 1) < 10**-10){
out <- 1
} else if (x <= 1){
out <- x
} else{
stop("Value should be less than 1")
}
return(out)
}
no_axis <- list(title = "",
zeroline = FALSE,
showline = FALSE,
showticklabels = FALSE,
showgrid = FALSE,
ticks = "")
setMethod(current_xaxis, c(x = "Iheatmap"),
function(x){x@current_xaxis})
setReplaceMethod("current_xaxis", c(x = "IheatmapHorizontal"),
function(x, value){x@current_xaxis <- value; x})
setMethod(current_yaxis, c(x = "Iheatmap"),
function(x){x@current_yaxis})
setReplaceMethod("current_yaxis", c(x = "IheatmapVertical"),
function(x, value){x@current_yaxis <- value; x})
setMethod(axis_text, c(x = "IheatmapMainAxis"),
function(x, ordered = FALSE){
if (x@categorical){
if (ordered){
return(as.character(x@text[x@order]))
} else{
return(as.character(x@text))
}
} else{
return(as.character(x@text))
}
})
setMethod(axis_values, c(x = "IheatmapMainAxis"),
function(x, ordered = FALSE){
if (x@categorical){
vals <- seq_along(x@text)
if (ordered){
return(vals[x@order])
} else{
return(vals)
}
} else{
return(as.numeric(x@text))
}
})
setMethod(axis_order, c(x = "IheatmapMainAxis"),
function(x){x@order})
setMethod(domain_start, c(x = "IheatmapAxis"),
function(x){x@domain_start})
setMethod(domain_start, c(x = "IheatmapAxes"),
function(x){vapply(x, domain_start, 1)})
setReplaceMethod("domain_start", c(x = "IheatmapAxis"),
function(x, value){x@domain_start <- value; x})
setReplaceMethod("domain_start", c(x = "IheatmapAxes"),
function(x, value){
for (i in seq_along(x)){
x[[i]]@domain_start <- value[i]
}
x})
setMethod('sort', c(x = "IheatmapAxes"),
function(x, decreasing = FALSE){
ix <- order(domain_start(x), decreasing = decreasing)
x[ix]
})
setMethod(domain_end, c(x = "IheatmapAxis"),
function(x){x@domain_end})
setMethod(domain_end, c(x = "IheatmapAxes"),
function(x){vapply(x, domain_end, 1)})
setReplaceMethod("domain_end", c(x = "IheatmapAxis"),
function(x, value){x@domain_end <- value; x})
setReplaceMethod("domain_end", c(x = "IheatmapAxes"),
function(x, value){
for (i in seq_along(x)){
x[[i]]@domain_end <- value[i]
}
x})
setMethod(id, c(x = "IheatmapAxis"),
function(x){x@id})
setMethod(id, c(x = "IheatmapAxes"),
function(x){vapply(x, id, "")})
setMethod(xaxis_name, c(x = "IheatmapPanel"),
function(x){x@xaxis})
setMethod(xaxis_name, c(x = "IheatmapPanels"),
function(x){vapply(x, xaxis_name,"")})
setMethod(xaxis_name, c(x = "Iheatmap"),
function(x){
unlist(c(xaxis_name(x@plots),
xaxis_name(x@shapes),
xaxis_name(x@annotations)))})
setMethod(yaxis_name, c(x = "IheatmapPanel"),
function(x){x@yaxis})
setMethod(yaxis_name, c(x = "IheatmapPanels"),
function(x){vapply(x, yaxis_name, "")})
setMethod(yaxis_name, c(x = "Iheatmap"),
function(x){
unlist(c(yaxis_name(x@plots),
yaxis_name(x@shapes),
yaxis_name(x@annotations)))})
setMethod('buffers', c(x = "IheatmapAxes"),
function(x){
stopifnot(identical(x, sort(x)))
if (length(x) > 1) domain_start(x)[2:length(x)] -
domain_end(x)[1:(length(x) - 1)] else c()
})
setReplaceMethod("axis_order", c("IheatmapMainAxis"),
function(x, value){
if (x@categorical){
x@order <- value
return(x)
} else{
stop("Cannot reorder continuous axis!")
}
})
setMethod(add_axis, c(p = "IheatmapHorizontal", new_axis = "IheatmapX"),
function(p,
new_axis,
xname,
size = 1,
buffer = 0.04,
side = c("left","right"),
...){
side <- match.arg(side)
axes <- sort(xaxes(p))
if (xname %in% names(axes)){
return(p)
}
ids <- id(axes)
main_ix <- which(ids == "x")
starts <- unname(domain_start(axes))
ends <- unname(domain_end(axes))
sizes <- ends - starts
main_size <- sizes[main_ix]
new_size <- main_size * size
buffer_sizes <- c(unname(buffers(axes)), buffer * main_size)
norm_factor <- sum(sizes) + sum(buffer_sizes) + new_size
new_size <- new_size / norm_factor
buffer_sizes <- buffer_sizes / norm_factor
sizes <- sizes / norm_factor
if (side == "right"){
domain_start(axes) <- starts / norm_factor
domain_end(axes) <- ends / norm_factor
domain_start(new_axis) <- 1 - new_size
domain_end(new_axis) <- 1
axes[[xname]] <- new_axis
} else{
domain_start(axes) <- 1 - ((1 - starts) / norm_factor)
domain_end(axes) <- 1 - ((1 - ends) / norm_factor)
domain_start(new_axis) <- 0
domain_end(new_axis) <- new_size
axes[[xname]] <- new_axis
}
p@xaxes <- axes
return(p)
})
setMethod(add_axis, c(p = "IheatmapHorizontal", new_axis = "IheatmapY"),
function(p,
new_axis,
yname,
xname,
size = 1,
buffer = 0.04,
side = c("top","bottom")){
side <- match.arg(side)
if (yname %in% names(yaxes(p))){
if (yname %in% names(yaxes(p, xname))){
return(p)
} else{
existing <- TRUE
}
} else{
existing <- FALSE
}
axes <- yaxes(p)
current <- sort(yaxes(p, xname))
ids <- id(current)
main_ix <- which(ids == "y")
starts <- unname(domain_start(current))
ends <- unname(domain_end(current))
sizes <- ends - starts
main_size <- sizes[main_ix]
if (existing){
existing_start <- domain_start(yaxes(p)[[yname]])
existing_end <- domain_end(yaxes(p)[[yname]])
new_size <- existing_end - existing_start
other_x <- names(xaxes(p, yname))
y_for_other_x <- sort(yaxes(p, other_x[[1]]))
if (side == "top" && existing_start < ends[main_ix])
stop("Mismatch between side and existing yname")
if (side == "bottom" && existing_start > starts[main_ix])
stop("Mismatch between side and existing yname")
y_ix <- which(names(y_for_other_x) == yname)
new_buffer_size <- if (side == "top"){
domain_start(y_for_other_x[y_ix]) -
domain_end(y_for_other_x[y_ix - 1])
} else{
domain_start(y_for_other_x[y_ix + 1]) -
domain_end(y_for_other_x[y_ix])
}
} else{
new_size <- main_size * size
new_buffer_size <- buffer * main_size
}
buffer_sizes <- unname(buffers(current))
if (side == "top"){
if (existing){
resize <- existing_start < (max(ends) + new_buffer_size)
} else{
needed_room <- new_size + new_buffer_size
available_room <- 1 - max(ends)
resize <- needed_room > available_room
}
if (resize){
#need to adjust sizes
if (existing){
norm_factor <- sum(sizes) + sum(buffer_sizes) + new_size +
new_buffer_size + min(starts) + (1-existing_end)
} else{
norm_factor <- sum(sizes) + sum(buffer_sizes) + new_size +
new_buffer_size + min(starts)
}
sizes <- sizes / norm_factor
buffer_sizes <- c(buffer_sizes, new_buffer_size) / norm_factor
new_size <- new_size / norm_factor
j <- min(starts) / norm_factor
for (i in seq_along(sizes)){
domain_start(axes[[names(current)[i]]]) <- j
domain_end(axes[[names(current)[i]]]) <- j + sizes[i]
j <- j + sizes[i] + buffer_sizes[i]
}
if (existing){
domain_start(axes[[yname]]) <- j
domain_end(axes[[yname]]) <- one_bounded(j + new_size)
} else{
domain_start(new_axis) <- j
domain_end(new_axis) <- one_bounded(j + new_size)
axes[[yname]] <- new_axis
}
} else{
if (!existing){
domain_start(new_axis) <- max(ends) + new_buffer_size
domain_end(new_axis) <- one_bounded(max(ends) +
new_buffer_size +
new_size)
axes[[yname]] <- new_axis
}
}
} else if (side == "bottom"){
if (existing){
resize <- existing_end > (min(starts) - new_buffer_size)
} else{
needed_room <- new_size + new_buffer_size
available_room <- min(starts)
resize <- needed_room > available_room
}
if (resize){
#need to adjust sizes
if (existing){
norm_factor <- sum(sizes) + sum(buffer_sizes) +
new_size + new_buffer_size + (1 - max(ends)) +
existing_start
} else{
norm_factor <- sum(sizes) + sum(buffer_sizes) +
new_size + new_buffer_size + (1 - max(ends))
}
sizes <- sizes / norm_factor
buffer_sizes <- c(new_buffer_size, buffer_sizes) / norm_factor
new_buffer_size <- new_buffer_size / norm_factor
new_size <- new_size / norm_factor
j <- 1 - ((1 - (max(ends))) / norm_factor)
for (i in rev(seq_along(sizes))){
domain_start(axes[[names(current)[i]]]) <- j - sizes[i]
domain_end(axes[[names(current)[i]]]) <- j
j <- j - sizes[i] - buffer_sizes[i]
}
if (existing){
domain_start(axes[[yname]]) <- zero_bounded(j - new_size)
domain_end(axes[[yname]]) <- j
} else{
domain_start(new_axis) <- zero_bounded(j - new_size)
domain_end(new_axis) <- j
axes[[yname]] <- new_axis
}
} else{
if (!existing){
domain_start(new_axis) <- zero_bounded(min(starts) -
new_buffer_size -
new_size)
domain_end(new_axis) <- min(starts) - new_buffer_size
axes[[yname]] <- new_axis
}
}
}
if (resize){
#Adjust additional y axes as well
additional_x_axes <- xaxes(p)[names(xaxes(p)) != xname]
for (k in names(additional_x_axes)){
additional <- sort(yaxes(p, k))
if (length(additional) >= 2){
additional_starts <- unname(domain_start(additional))
additional_ends <- unname(domain_end(additional))
additional_sizes <- (additional_ends - additional_starts) /
norm_factor
additional_buffer_sizes <- c(unname(buffers(additional)),0) /
norm_factor
new_ybottom <- domain_start(axes[[which(id(axes) == "y")]])
old_ybottom <- domain_start(yaxes(p)[[which(id(yaxes(p)) ==
"y")]])
old_bottom <- min(additional_starts)
j <- zero_bounded(new_ybottom - ((old_ybottom - old_bottom) /
norm_factor))
for (i in seq_along(additional_sizes)){
if (names(additional)[i] %ni% c(yname,names(current))){
domain_start(axes[[names(additional)[i]]]) <- j
domain_end(axes[[names(additional)[i]]]) <-
one_bounded(j + additional_sizes[i])
j <- j + additional_sizes[i] + additional_buffer_sizes[i]
} else{
j <- domain_end(axes[[names(additional)[i]]]) +
additional_buffer_sizes[i]
}
}
}
}
}
p@yaxes <- axes
return(p)
})
setMethod(add_axis, c(p = "IheatmapVertical", new_axis = "IheatmapY"),
function(p,
new_axis,
yname,
size = 1,
buffer = 0.04,
side = c("top","bottom"),
...){
side <- match.arg(side)
axes <- sort(yaxes(p))
if (yname %in% names(axes)){
return(p)
}
ids <- id(axes)
main_ix <- which(ids == "y")
starts <- unname(domain_start(axes))
ends <- unname(domain_end(axes))
sizes <- ends - starts
main_size <- sizes[main_ix]
new_size <- main_size * size
buffer_sizes <- c(unname(buffers(axes)), buffer * main_size)
norm_factor <- sum(sizes) + sum(buffer_sizes) + new_size
new_size <- new_size / norm_factor
buffer_sizes <- buffer_sizes / norm_factor
sizes <- sizes / norm_factor
if (side == "top"){
domain_start(axes) <- starts / norm_factor
domain_end(axes) <- ends / norm_factor
domain_start(new_axis) <- 1 - new_size
domain_end(new_axis) <- 1
axes[[yname]] <- new_axis
} else{
domain_start(axes) <- 1 - ((1 - starts) / norm_factor)
domain_end(axes) <- 1 - ((1 - ends) / norm_factor)
domain_start(new_axis) <- 0
domain_end(new_axis) <- new_size
axes[[yname]] <- new_axis
}
p@yaxes <- axes
return(p)
})
setMethod(add_axis, c(p = "IheatmapVertical", new_axis = "IheatmapX"),
function(p,
new_axis,
xname,
yname,
size = 1,
buffer = 0.04,
side = c("right","left")){
side <- match.arg(side)
if (xname %in% names(xaxes(p))){
if (xname %in% names(xaxes(p, yname))){
return(p)
} else{
existing <- TRUE
}
} else{
existing <- FALSE
}
axes <- xaxes(p)
current <- sort(xaxes(p, yname))
ids <- id(current)
main_ix <- which(ids == "x")
starts <- unname(domain_start(current))
ends <- unname(domain_end(current))
sizes <- ends - starts
main_size <- sizes[main_ix]
if (existing){
existing_start <- domain_start(xaxes(p)[[xname]])
existing_end <- domain_end(xaxes(p)[[xname]])
new_size <- existing_end - existing_start
other_y <- names(yaxes(p, xname))
x_for_other_y <- sort(xaxes(p, other_y[[1]]))
if (side == "right" && existing_start < ends[main_ix])
stop("Mismatch between side and existing x axis with xname")
if (side == "left" && existing_start > starts[main_ix])
stop("Mismatch between side and existing x axis with xname")
x_ix <- which(names(x_for_other_y) == xname)
new_buffer_size <- if (side == "top"){
domain_start(x_for_other_y[x_ix]) -
domain_end(x_for_other_y[x_ix - 1])
} else{
domain_start(x_for_other_y[x_ix + 1]) -
domain_end(x_for_other_y[x_ix])
}
} else{
new_size <- main_size * size
new_buffer_size <- buffer * main_size
}
buffer_sizes <- unname(buffers(current))
if (side == "right"){
if (existing){
resize <- existing_start < (max(ends) + new_buffer_size)
} else{
needed_room <- new_size + new_buffer_size
available_room <- 1 - max(ends)
resize <- needed_room > available_room
}
if (resize){
#need to adjust sizes
if (existing){
norm_factor <- sum(sizes) + sum(buffer_sizes) + new_size +
new_buffer_size + min(starts) + (1-existing_end)
} else{
norm_factor <- sum(sizes) + sum(buffer_sizes) + new_size +
new_buffer_size + min(starts)
}
sizes <- sizes / norm_factor
buffer_sizes <- c(buffer_sizes, new_buffer_size) / norm_factor
new_size <- new_size / norm_factor
j <- min(starts) / norm_factor
for (i in seq_along(sizes)){
domain_start(axes[[names(current)[i]]]) <- j
domain_end(axes[[names(current)[i]]]) <- j + sizes[i]
j <- j + sizes[i] + buffer_sizes[i]
}
if (existing){
domain_start(axes[[xname]]) <- j
domain_end(axes[[xname]]) <- one_bounded(j + new_size)
} else{
domain_start(new_axis) <- j
domain_end(new_axis) <- one_bounded(j + new_size)
axes[[xname]] <- new_axis
}
} else{
if (!existing){
domain_start(new_axis) <- max(ends) + new_buffer_size
domain_end(new_axis) <- one_bounded(max(ends) +
new_buffer_size +
new_size)
axes[[xname]] <- new_axis
}
}
} else if (side == "left"){
if (existing){
resize <- existing_end > (min(starts) - new_buffer_size)
} else{
needed_room <- new_size + new_buffer_size
available_room <- min(starts)
resize <- needed_room > available_room
}
if (resize){
#need to adjust sizes
if (existing){
norm_factor <- sum(sizes) + sum(buffer_sizes) +
new_size + new_buffer_size + (1 - max(ends)) +
existing_start
} else{
norm_factor <- sum(sizes) + sum(buffer_sizes) +
new_size + new_buffer_size + (1 - max(ends))
}
sizes <- sizes / norm_factor
buffer_sizes <- c(new_buffer_size, buffer_sizes) / norm_factor
new_buffer_size <- new_buffer_size / norm_factor
new_size <- new_size / norm_factor
j <- 1 - ((1 - (max(ends))) / norm_factor)
for (i in rev(seq_along(sizes))){
domain_start(axes[[names(current)[i]]]) <- j - sizes[i]
domain_end(axes[[names(current)[i]]]) <- j
j <- j - sizes[i] - buffer_sizes[i]
}
if (existing){
domain_start(axes[[xname]]) <- zero_bounded(j - new_size)
domain_end(axes[[xname]]) <- j
} else{
domain_start(new_axis) <- zero_bounded(j - new_size)
domain_end(new_axis) <- j
axes[[xname]] <- new_axis
}
} else{
if (!existing){
domain_start(new_axis) <- zero_bounded(min(starts) -
new_buffer_size -
new_size)
domain_end(new_axis) <- min(starts) - new_buffer_size
axes[[xname]] <- new_axis
}
}
}
if (resize){
#Adjust additional y axes as well
additional_y_axes <- yaxes(p)[names(yaxes(p)) != yname]
for (k in names(additional_y_axes)){
additional <- sort(xaxes(p, k))
if (length(additional) >= 2){
additional_starts <- unname(domain_start(additional))
additional_ends <- unname(domain_end(additional))
additional_sizes <- (additional_ends - additional_starts) /
norm_factor
additional_buffer_sizes <- c(unname(buffers(additional)),0) /
norm_factor
new_xbottom <- domain_start(axes[[which(id(axes) == "x")]])
old_xbottom <- domain_start(xaxes(p)[[which(id(xaxes(p)) ==
"x")]])
old_bottom <- min(additional_starts)
j <- zero_bounded(new_xbottom - ((old_xbottom - old_bottom) /
norm_factor))
for (i in seq_along(additional_sizes)){
if (names(additional)[i] %ni% c(xname,names(current))){
domain_start(axes[[names(additional)[i]]]) <- j
domain_end(axes[[names(additional)[i]]]) <-
one_bounded(j + additional_sizes[i])
j <- j + additional_sizes[i] + additional_buffer_sizes[i]
} else{
j <- domain_end(axes[[names(additional)[i]]]) +
additional_buffer_sizes[i]
}
}
}
}
}
p@xaxes <- axes
return(p)
})
Try the iheatmapr package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.