How can I adjust facet width in plotly in R?

Question

I'm currently in the process of creating a heatmap with plotly. Below is the sample dataset:

library(tidyverse)
library(plotly)
library(hrbrthemes)
set.seed(9999)
df <- data.frame(group.int = rep(c(rep("Prevention", 3), "Diagnosis", rep("Intervention", 2)), 6),
                int = rep(c("Prevention 1", "Prevention 2", "Prevention 3", "Diagnosis 1", "Intervention 1", "Intervention 2"), 6),
                group.outcome = c(rep("Efficacy", 12), rep("Safety", 18), rep("Cost-effectiveness", 6)),
                outcome = c(rep("Efficacy 1", 6), rep("Efficacy 2", 6), rep("Safety 1", 6), rep("Safety 2", 6), rep("Safety 3", 6), rep("Cost-effectiveness 1", 6)),
                n = sample(50:250, 36, rep = TRUE)
            )
df$group.int <- factor(df$group.int, levels = c("Prevention", "Diagnosis", "Intervention"))
df$group.outcome <- factor(df$group.outcome, levels = c("Efficacy", "Safety", "Cost-effectiveness"))

I want to make a heatmap based on the variable outcome against int, with n as the fill of each heatmap cell. Here is the desired plot:

I tried using ggplotly from the created ggplot:

plotly.df <- ggplot(df, 
                aes(x = int, y = outcome, fill= n)) + 
                geom_tile() +
                scale_fill_gradient(low="white", high="darkred") +
                scale_y_discrete(position = "right") +
                facet_grid(group.outcome ~ group.int,
                    scales = "free", space = "free", switch = "x") +
                theme_bw() +
                theme(axis.ticks = element_blank(),
                    legend.position = "left",
                    strip.placement = "outside", 
                    strip.background = element_blank())
ggplotly(plotly.df)

However, ggplotly seems to ignore space = "free" in facet_grid, so the size of the cells are not proportional:

Is there a way to adjust facet widths with ggplotly?

Thank you very much in advance

Answer 1

You don't have to reinvent the wheel. Go back to the first ggplotly object. Domain is what plotly uses to govern the spaces each facet (or as it is in plotly-subplot). You can retrieve this information by assigning the ggplotly graph to an object and calling plotly_json.

However, I've worked around layout shortcuts before. You can retrieve and modify the domains like this:

p = ggplotly(plotly.df)

p$x$layout$xaxis$domain <- c(0, 1/2) # 6 blocks, 3 in this group 1/6 * 3
p$x$layout$xaxis2$domain <- c(1/2, 2/3) # start at previous position, 1 in this group
p$x$layout$xaxis3$domain <- c(2/3, 1) # remaining space

p$x$layout$yaxis3$domain <- c(0, 1/6) # 1 block in bottom chunks
p$x$layout$yaxis2$domain <- c(1/6, 2/3) # 3 in mid group
p$x$layout$yaxis$domain <- c(2/3, 1) # remaining space
p

That got me this far:

Your bottom labels are still aligned, but the top is not. Additionally, the left bottom label is cut off.

To fix the top labels I used plotly_json to figure out where they were at then used the guess-and-check method. To adjust for labels, I modified the margin.

# prevention
p$x$layout$annotations[[3]]$x <- 1/4

# diagnosis
p$x$layout$annotations[[4]]$x <- 7/12

p %>% layout(margin = list(t = 40, r = 50, b = 80, l = 130))

---

---

Update based on comments

Consider the following as a replacement for everything that follows p = ggplotly(plotly.df) (So you won't use anything about this, but you'll see that the code above is still here.)

The facets

#------------- position and spacing facets -------------
p$x$layout$xaxis$domain <- c(0, 1/2)    # 6 blocks, 3 in this group 1/6 * 3
p$x$layout$xaxis2$domain <- c(1/2, 2/3) # 1 in this group
p$x$layout$xaxis3$domain <- c(2/3, 1)   # remaining space

p$x$layout$yaxis3$domain <- c(0, 1/6)   # 1 block in bottom chunks
p$x$layout$yaxis2$domain <- c(1/6, 2/3) # 3 in mid group
p$x$layout$yaxis$domain <- c(2/3, 1)    # remaining space

The labels

#------------- position and spacing labels -------------
# prevention
p$x$layout$annotations[[3]]$x <- 1/4

# diagnosis
p$x$layout$annotations[[4]]$x <- 7/12

# bottom group labels: prevention, diagnosis, intervention/ adjust down
lapply(3:5, function(i){
  p$x$layout$annotations[[i]]$y <<- -0.1575
})

# efficacy, safety and cost effectiveness/ shift right
lapply(6:8, function(i){
  p$x$layout$annotations[[i]]$x <<- 1.25
  p$x$layout$annotations[[i]]$yanchor <<- "top"
})

# int
p$x$layout$annotations[[1]]$y <- -0.07

# outcome
p$x$layout$annotations[[2]]$x <- 1.475
p$x$layout$annotations[[2]]$textangle <- 90 # 180 degree flip

The legend

#------------- position and spacing legend -------------
# capture the font sizes of the other annotations
tf <- p$x$layout$xaxis$tickfont

# change the font of the group labels
lapply(3:8, function(i){
  p$x$layout$annotations[[i]]$font <<- tf
})

# update the ticks to represent the values of n, not the scale 
getCol <- data.frame(p$x$data[[10]]$marker$colorscale) # capture the scale
getCol$n <- seq(from = 50, to = 208, along.with = 1:300) %>% round(digits = 0)
summary(getCol)
(getVals <- filter(getCol, n %in% seq(50, 200, by = 50)))
#          X1      X2   n
# 1 0.0000000 #FFFFFF  50
# 2 0.3143813 #E5B4A8 100
# 3 0.3177258 #E5B3A7 100
# 4 0.6321070 #C16B57 150
# 5 0.6354515 #C06A56 150
# 6 0.9464883 #941B0E 200
# 7 0.9498328 #931A0E 200 

# the legend
p$x$data[[10]]$marker$colorbar <- list(x = -.2, tickfont = tf,
                                       tickmode = "array",
                                       ticktext = seq(50, 200, by = 50),
                                   # from getVals output
                                       tickvals = c(0, .318, .636, .95),
                                       outlinewidth = 0,
                                       thickness = 20)

and finally...

# legend and yaxis labels; the final plot
p %>% layout(margin = list(t = 10, r = 170, b = 120, l = 10),
             yaxis = list(side = "right", anchor = "free", position = 1),
             yaxis2 = list(side = "right", anchor = "free", position = 1),
             yaxis3 = list(side = "right", anchor = "free", position = 1))