Color coding plotly text annotations according to a vector or gradient

user_5548896 0
Viewed 141

I have integer data that I want to plot using R's plotly as a heatmap with the elements of the heatmap color coded by the size of the integer data. I also want to annotate each element by a text annotation of the integer and also color code that text by the size of the integer data.

Here's the data:

library(dplyr)

pal <- grDevices::colorRamp(c("black","gray"))
set.seed(1)
df <- rbind(data.frame(col = "a",
                 group = paste0("g",1:20),
                 n = as.integer(runif(20, 1, 20))) %>%
  dplyr::mutate(text.col = rgb(pal((n - min(n))/diff(range(n))),max=255)),
  data.frame(col = "b",
             group = paste0("g",1:20),
             n = as.integer(runif(20, 1, 40))) %>%
    dplyr::mutate(text.col = rgb(pal((n - min(n))/diff(range(n))),max=255)))
df$group <- factor(df$group, levels = paste0("g",1:20))

So my heatmap will have 20 rows corresponding to df$group and 2 columns corresponding to df$col. As you can see I'm specifying the color of each element in df.

Here's a data.frame specifying the color range of the heatmap's background color, for each df$col:

colors.df <- data.frame(col = c("a", "b"),
                        fill.low = c("#a6c4ba", "#f2edda"),
                        fill.high = c("#4e8a75", "#b49823"),
                        stringsAsFactors = F)

And here's my plotly code:

lapply(c("a","b"), function(l){
  col.df <- dplyr::filter(df, col == l)
  n.text <- as.character(col.df$n)
  plotly::plot_ly(ygap = 1, z = col.df$n, x = col.df$col, y =col.df$group,
                  colors = grDevices::colorRamp(c(dplyr::filter(colors.df,col == l)$fill.low, dplyr::filter(colors.df,col == l)$fill.high)), type = "heatmap") %>%
    plotly::hide_colorbar() %>%
    plotly::add_annotations(font = list(color = col.df$text.col, size = 8),text = n.text,x = col.df$col,y = col.df$group,showarrow = F)
}) %>% plotly::subplot(shareX = T, shareY = T, nrows = 1, margin = 0.001, widths = c(0.5, 0.5))

Which gives: enter image description here

As you can see passing col.df$text.col to the font list in plotly::add_annotations is not obeyed and all text annotations are color with the same color.

Any idea how to get them colored according to col.df$text.col?

color-coding plotly heatmap r annotations
1 Answers

Plotly's interpretations of your code led to every possible color listed for each of the 40 annotations.

So how do I know this? The first thing I did was send the plot to an object, like so:

lapply(c("a","b"), function(l){
  col.df <- dplyr::filter(df, col == l)
  n.text <- as.character(col.df$n)
  plotly::plot_ly(data = col.df, ygap = 1, 
                  z = ~n, x = ~col, y = ~group,
                  colors = grDevices::colorRamp(
                    c(dplyr::filter(colors.df, col == l)$fill.low, 
                      dplyr::filter(colors.df, col == l)$fill.high)), 
                  type = "heatmap") %>%
    plotly::hide_colorbar() %>%
    plotly::add_annotations(font = list(color = ~text.col, size = 8),
                            text = n.text, x = ~col,
                            y = ~group, showarrow = F)
  }) %>% 
  plotly::subplot(shareX = T, shareY = T, nrows = 1, 
                  margin = 0.001, widths = c(0.5, 0.5)) -> a

I wanted to view the plot object in the source pane. However, this plot wasn't a complete build, so I did that next.

a <- plotly_build(a)  # embed the JSON data and layout

Then I looked at the object again.

enter image description here

You can see the list of values for color in that image. So, let's help Plotly decide on one color since it seems rather indecisive today.

lapply(1:40,
       function(k){
         base = a$x$layout$annotations[[k]] # find the annotation
         # find the color that should be there
         col = filter(df, col == base$x, group == base$y) %>%  
           select(text.col) %>% unlist()
         # change the plotly object
         a$x$layout$annotations[[k]]$font$color <<- col
       })
a # take another look at that graph

enter image description here

This is what you wanted, but it's really hard to read!

I made the text bold to see if the legibility improved.

lapply(1:40,
       function(j){
         base = a$x$layout$annotations[[j]]
         t = base$text
         a$x$layout$annotations[[j]]$text <<- paste0('<b>', t, '</b>')
       })

a # any better?

enter image description here

It helped a little. I'll leave it for you to figure out. If you have any questions, let me know.

user_53290730
Related