Skip to content

Commit

Permalink
Merge pull request #111 from stemangiola/add-layer_text
Browse files Browse the repository at this point in the history 
add text framework
  • Loading branch information
@stemangiola
stemangiola committed Mar 23, 2023
2 parents 6b16004 + 0d28055 commit 035137b
Show file tree
Hide file tree
Showing 27 changed files with 2,400 additions and 39 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
Type: Package
Package: tidyHeatmap
Title: A Tidy Implementation of Heatmap
Version: 1.9.2
Version: 1.10.0
Authors@R:
c(person(given = "Stefano",
family = "Mangiola",
Expand Down
2 changes: 2 additions & 0 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,6 +18,7 @@ export(layer_diamond)
export(layer_point)
export(layer_square)
export(layer_star)
export(layer_text)
export(save_pdf)
export(scale_robust)
export(split_columns)
Expand All @@ -42,6 +43,7 @@ importFrom(grDevices,colorRampPalette)
importFrom(grid,gpar)
importFrom(grid,grid.grabExpr)
importFrom(grid,grid.points)
importFrom(grid,grid.text)
importFrom(grid,unit)
importFrom(grid,unit.c)
importFrom(lifecycle,deprecate_warn)
Expand Down
1 change: 1 addition & 0 deletions R/functions.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -510,3 +510,4 @@ setMethod("layer_symbol", "InputHeatmap", function(.data,


})

195 changes: 167 additions & 28 deletions R/methods.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,8 @@ InputHeatmap<-setClass(
top_annotation = "tbl",
left_annotation = "tbl",
arguments = "list" ,
layer_symbol = "tbl"
layer_symbol = "tbl",
layer_text = "tbl"
),
prototype=list(
palette_discrete=
Expand All @@ -36,7 +37,9 @@ InputHeatmap<-setClass(
left_annotation = tibble(col_name = character(), orientation = character(), col_orientation = character(), data = list(), fx = list(), annot = list(), annot_type= character(), idx = integer(), color = list(), further_arguments = list()),
group_top_annotation = list(),
group_left_annotation = list(),
layer_symbol = tibble(column = integer(), row = integer(), shape = integer())
layer_symbol = tibble(column = integer(), row = integer(), shape = integer()),
layer_text = tibble(column = integer(), row = integer(), text = character(), size = numeric())

)
)

Expand All @@ -49,7 +52,7 @@ InputHeatmap<-setClass(
#'
#' @importFrom methods show
#' @importFrom tibble rowid_to_column
#' @importFrom grid grid.points
#' @importFrom grid grid.points grid.text
#'
#'
#' @name as_ComplexHeatmap
Expand Down Expand Up @@ -124,21 +127,44 @@ setMethod("as_ComplexHeatmap", "InputHeatmap", function(tidyHeatmap){

# On-top layer
tidyHeatmap@input$layer_fun = function(j, i, x, y, w, h, fill) {


# Add symbol
ind =
tibble(row = i, column = j) |>
rowid_to_column("index_column_wise") |>

# Filter just points to label
inner_join(tidyHeatmap@layer_symbol, by = c("row", "column")) |>
select(`index_column_wise`, `shape`)
inner_join(tidyHeatmap@layer_symbol, by = c("row", "column"))

if(nrow(ind)>0)
# Return graphical elements
if(nrow(ind)>0){
grid.points(
x[ind$index_column_wise], y[ind$index_column_wise],
pch = ind$shape ,
size = unit(3, "mm"),
gp = gpar(col = NULL, fill="#161616")
)
}

# Add text
ind_text =
tibble(row = i, column = j) |>
rowid_to_column("index_column_wise") |>

# Filter just points to label
inner_join(tidyHeatmap@layer_text, by = c("row", "column"))

# Return graphical elements
if(nrow(ind_text) > 0){
grid.text(
ind_text$text,
x[ind_text$index_column_wise],
y[ind_text$index_column_wise],
gp = gpar(fontsize = ind_text$size, col = "#000000")
)
}

}

return(do.call(Heatmap, tidyHeatmap@input))
Expand Down Expand Up @@ -249,13 +275,13 @@ heatmap_ <-

# Check if scale is of correct type
if(scale %in% c("none", "row", "column", "both") |> not()) stop("tidyHeatmap says: the scale parameter has to be one of c(\"none\", \"row\", \"column\", \"both\")")

# # Message about change of style, once per session
# if(length(palette_grouping)==0 & getOption("tidyHeatmap_white_group_message",TRUE)) {
# message("tidyHeatmap says: (once per session) from release 1.2.3 the grouping labels have white background by default. To add color for one-ay grouping specify palette_grouping = list(c(\"red\", \"blue\"))")
# options("tidyHeatmap_white_group_message"=FALSE)
# }

# Message about change of scale, once per session
if(scale == "none" & getOption("tidyHeatmap_default_scaling_none",TRUE)) {
message("tidyHeatmap says: (once per session) from release 1.7.0 the scaling is set to \"none\" by default. Please use scale = \"row\", \"column\" or \"both\" to apply scaling")
Expand All @@ -265,7 +291,7 @@ heatmap_ <-
.row = enquo(.row)
.column = enquo(.column)
.value <- enquo(.value)

# Validation
.data |> validation(!!.column, !!.row, !!.value)

Expand All @@ -276,7 +302,7 @@ heatmap_ <-
deprecate_warn("1.7.0", "tidyHeatmap::heatmap(.scale = )", details = "Please use scale (without dot prefix) instead: heatmap(scale = ...)")

scale = .scale

}

.data |>
Expand Down Expand Up @@ -378,8 +404,8 @@ setMethod("heatmap", "tbl_df", heatmap_)
#'
#' @export
setGeneric("annotation_tile", function(.data,
.column,
palette = NULL, size = NULL, ...)
.column,
palette = NULL, size = NULL, ...)
standardGeneric("annotation_tile"))

#' annotation_tile
Expand All @@ -390,8 +416,8 @@ setGeneric("annotation_tile", function(.data,
#' @return A `InputHeatmap` object that gets evaluated to a `ComplexHeatmap`
#'
setMethod("annotation_tile", "InputHeatmap", function(.data,
.column,
palette = NULL, size = NULL,...){
.column,
palette = NULL, size = NULL,...){

.column = enquo(.column)

Expand Down Expand Up @@ -462,8 +488,8 @@ setMethod("annotation_tile", "InputHeatmap", function(.data,
#'
#' @export
setGeneric("annotation_point", function(.data,
.column,
palette = NULL, size = NULL,...)
.column,
palette = NULL, size = NULL,...)
standardGeneric("annotation_point"))

#' annotation_point
Expand All @@ -474,8 +500,8 @@ setGeneric("annotation_point", function(.data,
#' @return A `InputHeatmap` object that gets evaluated to a `ComplexHeatmap`
#'
setMethod("annotation_point", "InputHeatmap", function(.data,
.column,
palette = NULL, size = NULL,...){
.column,
palette = NULL, size = NULL,...){

.column = enquo(.column)

Expand Down Expand Up @@ -524,8 +550,8 @@ setMethod("annotation_point", "InputHeatmap", function(.data,
#'
#' @export
setGeneric("annotation_line", function(.data,
.column,
palette = NULL,size = NULL, ...)
.column,
palette = NULL,size = NULL, ...)
standardGeneric("annotation_line"))

#' annotation_line
Expand All @@ -537,8 +563,8 @@ setGeneric("annotation_line", function(.data,
#' @return A `InputHeatmap` object that gets evaluated to a `ComplexHeatmap`
#'
setMethod("annotation_line", "InputHeatmap", function(.data,
.column,
palette = NULL, size = NULL,...){
.column,
palette = NULL, size = NULL,...){

.column = enquo(.column)

Expand Down Expand Up @@ -587,8 +613,8 @@ setMethod("annotation_line", "InputHeatmap", function(.data,
#'
#' @export
setGeneric("annotation_bar", function(.data,
.column,
palette = NULL, size = NULL,...)
.column,
palette = NULL, size = NULL,...)
standardGeneric("annotation_bar"))

#' annotation_bar
Expand All @@ -599,8 +625,8 @@ setGeneric("annotation_bar", function(.data,
#' @return A `InputHeatmap` object that gets evaluated to a `ComplexHeatmap`
#'
setMethod("annotation_bar", "InputHeatmap", function(.data,
.column,
palette = NULL, size = NULL,...){
.column,
palette = NULL, size = NULL,...){

.column = enquo(.column)

Expand Down Expand Up @@ -897,7 +923,7 @@ setMethod("layer_diamond", "InputHeatmap", function(.data, ...){ .data |> layer_
#'
#' @export
setGeneric("layer_star", function(.data, ...)
standardGeneric("layer_star"))
standardGeneric("layer_star"))

#' layer_star
#'
Expand Down Expand Up @@ -947,7 +973,7 @@ setMethod("layer_star", "InputHeatmap", function(.data, ...){ .data |> layer_sym
#'
#' @export
setGeneric("layer_asterisk", function(.data, ...)
standardGeneric("layer_asterisk"))
standardGeneric("layer_asterisk"))

#' layer_asterisk
#'
Expand All @@ -959,6 +985,119 @@ setGeneric("layer_asterisk", function(.data, ...)
#'
setMethod("layer_asterisk", "InputHeatmap", function(.data, ...){ .data |> layer_symbol(..., symbol="asterisk") })


#' Adds a layers of texts above the heatmap tiles to a `InputHeatmap`, that on evaluation creates a `ComplexHeatmap`
#'
#' \lifecycle{maturing}
#'
#' @description layer_text() from a `InputHeatmap` object, adds a text annotation layer.
#'
#' @importFrom rlang enquo
#' @importFrom magrittr "%>%"
#'
#'
#'
#' @name layer_text
#' @rdname layer_text-method
#'
#' @param .data A `InputHeatmap`
#' @param ... Expressions that return a logical value, and are defined in terms of the variables in .data. If multiple expressions are included, they are combined with the & operator. Only rows for which all conditions evaluate to TRUE are kept.
#' @param .value A column name or character string.
#' @param .size A column name or a double.
#'
#'
#' @details It uses `ComplexHeatmap` as visualisation tool.
#'
#' @return A `InputHeatmap` object that gets evaluated to a `ComplexHeatmap`
#'
#'
#'
#' @examples
#'
#' library(dplyr)
#'
#' hm =
#' tidyHeatmap::N52 |>
#' mutate(my_text = "t") |>
#' tidyHeatmap::heatmap(
#' .row = symbol_ct,
#' .column = UBR,
#' .value = `read count normalised log`
#' )
#'
#' hm |> layer_text(.value = "a")
#' hm |> layer_text(.value = my_text)
#'
#' @export
setGeneric("layer_text", function(.data,
...,
.value,
.size = NULL)
standardGeneric("layer_text"))

#' layer_text
#'
#' @importFrom rlang quo_is_null
#'
#' @docType methods
#' @rdname layer_text-method
#'
#'
#' @return A `InputHeatmap` object that gets evaluated to a `ComplexHeatmap`
#'
setMethod("layer_text", "InputHeatmap", function(.data,
...,
.value,
.size = NULL){

.data_drame = .data@data
.size = enquo(.size)

# Comply with CRAN NOTES
. = NULL
column = NULL
row = NULL

# Make col names
# Column names
.horizontal = .data@arguments$.horizontal
.vertical = .data@arguments$.vertical
.abundance = .data@arguments$.abundance

# Extract the abundance matrix for dimensions of the text
abundance_mat = .data@input[[1]]

# Append which cells have to be signed
.data@layer_text=
.data@layer_text |>
bind_rows(

.data_drame |>
droplevels() |>
mutate(
column = !!.horizontal %>% as.factor() %>% as.integer(),
row = !!.vertical %>% as.factor() %>% as.integer()
) |>
filter(...) |>

mutate(text := as.character( !!enquo(.value) )) |>

# Add size
when(
quo_is_null(.size) ~ mutate(., size = min(12, 320 / max(dim(abundance_mat)) )) ,
~ mutate(., size := !!.size )
) |>

select(column, row, text, size)


)

.data


})

#' Split the heatmap row-wise depending on the biggest branches in the cladogram.
#'
#' \lifecycle{maturing}
Expand Down
Loading

0 comments on commit 035137b

Please sign in to comment.