feature request: use "free text" symbol in layer_symbol(), and add color, size options

[frankyan]

Thank you for creating this fantastic package.

I want to display some values in the heatmap cells. Although he cell_fun or layer_fun argument from ComplexHeatmap can be added to tidyHeatmap::heatmap function to customize the display, I think it's much better and user-friendly to implement it in tidyHeatmap functions, similar to the layer_symbol() function.

The idea is to add freetext, color, and size to the layer_symbol() function. Then the layer_symbol() function is much more customizable. I have modified the code and created a pull request.
#107 (comment)

Here are some examples.

mtcars_tidy %>% 
  mutate(label = sprintf("%.1f", Value),
         color_label = ifelse(Value > 0, "darkred", "white")) %>% 
  heatmap(`Car name`, Property, Value, 
          palette_value = colorRamp2(c(-3, 0, 3), c("blue", "white", "red")))  %>% 
  layer_symbol(Value > 1 | Value < -1,
               symbol = "freetext", 
               freetext = label, 
               color = color_label, 
               size = 10)

mtcars_tidy %>% 
  heatmap(`Car name`, Property, Value, 
          palette_value = colorRamp2(c(-3, 0, 3), c("blue", "white", "red")))  %>% 
  layer_symbol(Value > 1,
               symbol = "freetext", 
               freetext = "+", 
               size = 10) %>%
  layer_symbol(Value < -1,
               symbol = "freetext", 
               freetext = "-", 
               size = 15) 

mtcars_tidy %>% 
  heatmap(`Car name`, Property, Value, 
          palette_value = colorRamp2(c(-3, 0, 3), c("blue", "white", "red")))  %>% 
  layer_point(Value < -1, color = "yellow")

[stemangiola]

Thanks a lot!

I left a review of your pull request.

[frankyan]

Thank you. I will follow your suggestions to make changes and update it later.

[stemangiola]

I have added the text support, although with no color

[stemangiola]

Close for inactivity

[ggruenhagen3]

I second the request for color control. It's very helpful to have control over the color of text in order to prevent the text color from being too similar to the heatmap color and becoming unreadable. Even just setting one color across the whole heatmap would be great. Currently, I think only black is possible and my black text text is unreadable against a red-blue color palette. If it's easier to have a gp argument for the gpar() of the text, that would work nicely as well I think.

[stemangiola]

Could you please post the ComplexHeatmep example on how the text is coloured?

Thanks.

[ggruenhagen3]

Here is a small reproducible example showing how text is colored in ComplexHeatmap:

set.seed(123)
mat = matrix(rnorm(200), nrow=10, ncol=20)
Heatmap(mat, cell_fun = function(j, i, x, y, width, height, fill) { grid.text(sprintf("%.1f", mat[i, j]), x, y, gp=gpar(col="#ffffff")) })

Here's what the resulting heatmap looks like (note the white text):

In case it helps, I wrote some code to modify some tidyHeatmap functions to allow a .color argument to layer_text. I will share it below. Sorry, that I'm sharing it in this format instead of as a pull request, I'm not too familiar doing pull requests.

Modified tidyHeatmap functions (including layer_text)

Modified layer_text

setGeneric("layer_text", function(.data,
																	...,
																	.value,
																	.size = NULL,
																	.color = NULL)
	standardGeneric("layer_text"))

setMethod("layer_text", "InputHeatmap", function(.data,
																								 ...,
																								 .value,
																								 .size = NULL,
																								 .color = NULL){
	
	.data_drame = .data@data
	.size = enquo(.size)
	.color = enquo(.color)
	
	# 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(
					rlang::quo_is_null(.size) ~ mutate(., size = min(12, 320 / max(dim(abundance_mat)) )) ,
					~ mutate(., size := !!.size )
					) |> 
				
				# Add color
				when(
					rlang::quo_is_null(.color) ~ mutate(., color = "#ffffff" ),
					~ mutate(., color := !!.color )
					) |> 
				
				select(column, row, text, size, color) 
				

		)
	
	.data
	
	
})

Modified as_ComplexHeatmap at grid.text

setMethod("as_ComplexHeatmap", "InputHeatmap", function(tidyHeatmap) {
	
	# Fix CRAN notes
	. = NULL
	index_column_wise = NULL
	shape = NULL
	
	top_annotations <- c(
	  tidyHeatmap@group_top_annotation,
	  tidyHeatmap@top_annotation |> tidyHeatmap:::annot_to_list()
	) |>
	  tidyHeatmap:::list_drop_null() |> 
	  tidyHeatmap:::filter_args(
	    HeatmapAnnotation, 
	    force_keep = 	    
	      seq_len(nrow(tidyHeatmap@top_annotation) + length(tidyHeatmap@group_top_annotation))

	   ) # force keep because columnAnnotation, which calls HeatmapAnnotation has ellipse as first argument. Pretty peculiar setup |>
	
	
	tidyHeatmap@input$top_annotation <- 
	  if (length(top_annotations) > 0 && !is.null(top_annotations)) {
	    do.call("columnAnnotation", top_annotations)
	  } else {
	    NULL
	  }
	
	left_annotations <- c(
	  tidyHeatmap@group_left_annotation,
	  tidyHeatmap@left_annotation |> tidyHeatmap:::annot_to_list()
	) |>
	  tidyHeatmap:::list_drop_null() |> 
	  tidyHeatmap:::filter_args(
	    HeatmapAnnotation, 
	    force_keep = 
	      seq_len(nrow(tidyHeatmap@left_annotation) + length(tidyHeatmap@group_left_annotation))
	   ) # force keep because columnAnnotation, which calls HeatmapAnnotation has ellipse as first argument. Pretty peculiar setup
	
	tidyHeatmap@input$left_annotation <- 
	  if (length(left_annotations) > 0 && !is.null(left_annotations)) {
	    do.call("rowAnnotation", left_annotations)
	  } else {
	    NULL
	  }
	
	# 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"))
		
		# Return graphical elements
		if(nrow(ind)>0){
			grid.points(
				x[ind$index_column_wise], y[ind$index_column_wise], 
				pch = ind$shape , 
				size = unit(ind$size, "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 = ind_text$color)
			)
		}
		
	}
	
	return(do.call(Heatmap, tidyHeatmap@input))
})

Modified the global variables, but I'm not sure if this is necessary or not

utils::globalVariables(c("shape", "size", "color", "text", ":="))

Modified 'InputHeatmap' at the layer_text tibble

InputHeatmap <- setClass(
	"InputHeatmap",  
	slots = list(
		input = "list", 
		data = "tbl",
		palette_discrete = "list", 
		palette_continuous = "list",
		group_top_annotation = "list",
		group_left_annotation = "list",
		top_annotation = "tbl",
		left_annotation = "tbl",
		arguments = "list" ,
		layer_symbol = "tbl",
		layer_text = "tbl"
	),
	prototype = list(
		palette_discrete = list(
			brewer.pal(9, "Set1"),
			brewer.pal(8, "Set2"),
			brewer.pal(12, "Set3"),
			brewer.pal(8, "Dark2"),
			brewer.pal(8, "Accent"),
			brewer.pal(8, "Pastel2")
		), 
		palette_continuous = list(
			brewer.pal(11, "Spectral") |> rev(),
			viridis(n = 5),
			magma(n = 5),
			brewer.pal(11, "PRGn"),
			brewer.pal(11, "BrBG")
		),
		input = list(),
		top_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()),
		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_text = tibble(column = integer(), row = integer(), text = character(), size = numeric(), color = character())
	)
) 

With this code I was able to call layer_text like below. The color argument is super convenient because it means I can made text readable over the whole heatmap, by setting different colored text for dark areas vs light areas.
layer_text(.value=n, .size=4, .color="#ffffff")

Finally, I'd like to once again thank you for making this amazing package, it's helped me a lot to make really good visualizations w/ most of the complexity of ComplexHeatmap, but w/ much more ease!

[stemangiola]

Thanks for the code, please have a look at the PR above, test it, and please View the vignette for the example.

[ggruenhagen3]

Looks great to me! Thanks for adding this feature! 🎉

An example of a heatmap I created while testing:

set.seed(123)
mat = matrix(rnorm(200), nrow=10, ncol=20)
mat_melt = tibble::as_tibble(reshape2::melt(mat))
mat_melt$text = sprintf("%.1f", mat_melt$value)
tidy_ht = mat_melt |> tidyHeatmap::heatmap(.row=Var1, .column=Var2, .value=value) |> layer_text(value < 0, .value=text, .color='white') |> layer_text(value > 0, .value=text, .color='black')
tidy_ht |> wrap_heatmap() %>% ggsave('Rplots.png', ., width=10, height=8)