Related
I don't quite understand why the legend disappeared when I converted a plot made by ggplot to plotly using ggplotly. The plotly help page did not have any information. I don't think their examples even worked properly on that page.
Any help is greatly appreciated!
Sample data
library(scales)
packageVersion("ggplot2")
#> [1] '3.4.0'
library(plotly)
packageVersion("plotly")
#> [1] '4.10.1'
data <- data.frame(
stringsAsFactors = FALSE,
Level = c("Fast","Fast","Fast","Fast",
"Fast","Fast","Slow","Slow","Slow",
"Slow","Slow","Slow"),
Period = c("1Year","3Month","1Year","3Month",
"1Year","3Month","1Year","3Month",
"1Year","3Month","1Year","3Month"),
X = c(0.002,0.002,0.1,0.1,0.9,0.9,
0.002,0.002,0.1,0.1,0.9,0.9),
Y = c(1.38,1.29,1.61,1.61,1.74,0.98,
1.14,0.97,1.09,1.1,0.94,0.58)
)
ggplot2
plt <- ggplot(data = data,
aes(x = X,
y = Y,
shape = Period,
color = Level)) +
geom_point(alpha = 0.6, size = 3) +
labs(x = " ",
y = "Value") +
scale_y_continuous(labels = number_format(accuracy = 0.1)) +
guides(color = guide_legend(title = "Level", order = 1),
shape = guide_legend(title = "Period", order = 2)) +
theme(axis.text.x = element_text(angle = 90))
plt
Convert to plotly, legend disappeared
ggplotly(plt, height = 500) %>%
layout(xaxis = list(autorange = "reversed"))
Edit
There was an issue with guides(). If I removed it, the legend in ggplotly showed up
plt2 <- ggplot(data = data,
aes(x = X,
y = Y,
shape = Period,
color = Level)) +
geom_point(alpha = 0.6, size = 3) +
labs(x = " ",
y = "Value") +
scale_y_continuous(labels = number_format(accuracy = 0.1)) +
theme(axis.text.x = element_text(angle = 90))
plt2
ggplotly(plt2, height = 500) %>%
layout(
xaxis = list(autorange = "reversed"),
legend = list(
title = list(text = '(Period, Level)'))
)
After OPs Edit:
Here is a workaround using basic R {plotly} to modify the legend according to #Tung's requirements:
library(scales)
library(ggplot2)
library(plotly)
library(data.table)
DT <- data.frame(
stringsAsFactors = FALSE,
Level = c("Fast","Fast","Fast","Fast",
"Fast","Fast","Slow","Slow","Slow",
"Slow","Slow","Slow"),
Period = c("1Year","3Month","1Year","3Month",
"1Year","3Month","1Year","3Month",
"1Year","3Month","1Year","3Month"),
X = c(0.002,0.002,0.1,0.1,0.9,0.9,
0.002,0.002,0.1,0.1,0.9,0.9),
Y = c(1.38,1.29,1.61,1.61,1.74,0.98,
1.14,0.97,1.09,1.1,0.94,0.58)
)
setDT(DT)
LevelDT <- unique(DT, by = "Level")
PeriodDT <- unique(DT, by = "Period")
LevelDT[, Y := min(DT$Y)-1]
PeriodDT[, Y := min(DT$Y)-1]
plt2 <- ggplot(data = DT,
aes(x = X,
y = Y,
shape = Period,
color = Level)) +
geom_point(alpha = 0.6, size = 3) +
labs(x = " ",
y = "Value") +
scale_y_continuous(labels = number_format(accuracy = 0.1)) +
theme(axis.text.x = element_text(angle = 90))
plt2
markercolors <- hue_pal()(2)
ggplotly(plt2, height = 500) |>
layout(
xaxis = list(autorange = "reversed"),
legend = list(
title = list(text = ''),
itemclick = FALSE,
itemdoubleclick = FALSE,
groupclick = FALSE
)
) |>
add_trace(
data = LevelDT,
x = ~ X,
y = ~ Y,
inherit = FALSE,
type = "scatter",
mode = "markers",
marker = list(
color = markercolors,
size = 14,
opacity = 0.6,
symbol = "circle"
),
name = ~ Level,
legendgroup = "Level",
legendgrouptitle = list(text = "Level")
) |>
add_trace(
data = PeriodDT,
x = ~ X,
y = ~ Y,
inherit = FALSE,
type = "scatter",
mode = "markers",
marker = list(
color = "darkgrey",
size = 14,
opacity = 0.6,
symbol = c("circle", "triangle-up")
),
name = ~Period,
legendgroup = "Period",
legendgrouptitle = list(text = "Period")
) |> style(showlegend = FALSE, traces = 1:4)
Original answer:
I'm not sure why they are set to FALSE in the first place, but setting showlegend = TRUE in layout() and style() (for the traces) brings back the legend:
library(scales)
library(ggplot2)
library(plotly)
data <- data.frame(
stringsAsFactors = FALSE,
Level = c("Fast","Fast","Fast","Fast",
"Fast","Fast","Slow","Slow","Slow",
"Slow","Slow","Slow"),
Period = c("1Year","3Month","1Year","3Month",
"1Year","3Month","1Year","3Month",
"1Year","3Month","1Year","3Month"),
X = c(0.002,0.002,0.1,0.1,0.9,0.9,
0.002,0.002,0.1,0.1,0.9,0.9),
Y = c(1.38,1.29,1.61,1.61,1.74,0.98,
1.14,0.97,1.09,1.1,0.94,0.58)
)
# ggplot2
plt <- ggplot(data = data,
aes(x = X,
y = Y,
shape = Period,
color = Level)) +
geom_point(alpha = 0.6, size = 3) +
labs(x = " ",
y = "Value") +
scale_y_continuous(labels = number_format(accuracy = 0.1)) +
guides(color = guide_legend(title = "Period", order = 1),
shape = guide_legend(title = "", order = 2)) +
theme(axis.text.x = element_text(angle = 90))
plt
# Convert to plotly, legend disappeared
fig <- ggplotly(plt, height = 500) %>%
layout(showlegend = TRUE, xaxis = list(autorange = "reversed")) %>%
style(showlegend = TRUE)
fig
This answer is for plotly 4.10.1. I have defined two functions:
set_legend_names() This edits the names of the htmlwidget created by ggplotly(), before it is passed to plotly.js.
set_legend_symbols(). This appends some js to the htmlwidget object to change the symbols after plotly.js has drawn them.
plt2 |>
ggplotly(height = 500) |>
layout(xaxis = list(autorange = "reversed")) |>
set_legend_names() |>
set_legend_symbols()
Function definitions:
1. set_legend_names()
set_legend_names <- function(p,
new_legend_names = c(
"Fast", "Slow", "One Year", "Three Month"
)) {
# Update legend names and put in one group
for (i in seq_along(p$x$data)) {
p$x$data[[i]]$name <- new_legend_names[i]
}
p$x$layout$legend$title <- ""
return(p)
}
2. set_legend_symbols()
set_legend_symbols <- function(p,
symbol_nums_change_color = c(3, 4),
new_color_string = "rgb(105, 105, 105)",
symbols_num_change_shape = 3,
symbols_nums_target_shape = 1) {
js_get_legend <- htmltools::HTML(
'let legend = document.querySelector(".scrollbox");
let symbols = legend.getElementsByClassName("legendsymbols");
const re = new RegExp("fill: rgb.+;", "i");\n
'
)
js_symbol_const <- paste0(
'const shape_re = new RegExp(\'d=".*?"\');\n',
"const correct_shape = symbols[",
symbols_nums_target_shape,
"].innerHTML.match(shape_re)[0];\n"
)
# subtract 1 for 0-indexed js
change_symbol_color_code <- lapply(
symbol_nums_change_color - 1,
\(i)
paste0(
"symbols[", i, "].innerHTML = ",
"symbols[", i, "].innerHTML.replace(re,",
' "fill: ', new_color_string, ';");'
)
) |>
paste(collapse = "\n")
# subtract 1 for 0-indexed js
change_symbols_shape_code <- lapply(
symbols_num_change_shape - 1,
\(i)
paste0(
"symbols[", i, "].innerHTML = symbols[",
symbols_nums_target_shape, "].innerHTML.replace(shape_re, correct_shape);"
)
) |>
paste(collapse = "\n")
all_js <- htmltools::HTML(
unlist(c(
js_get_legend,
js_symbol_const,
change_symbols_shape_code,
change_symbol_color_code
))
)
# Add it to the plot
p <- htmlwidgets::prependContent(
p,
htmlwidgets::onStaticRenderComplete(all_js)
)
return(p)
}
I've never posted a second answer before but it seems substantially different in plotly 4.10.1. I eagerly anticipate the release of plotly 4.10.2 so I can post a third answer.
Plotly generates a different legend from ggplot2 - this can be fixed with R and and a little javascript
The first thing to do is ensure that you have a reasonably current version of the packages:
packageVersion("ggplot2") # 3.4.0
packageVersion("plotly") # 4.10.0
With these versions, like #Quentin, I do get a legend, although it is different to the one generated by ggplot2.
ggplotly(plt, height = 500) %>%
layout(xaxis = list(autorange = "reversed"))
Steps to replicate the ggplot2 legend:
Change the legend text. This can be done by editing the R object before it is passed to plotly.js.
Remove the color from the shape guide. This can only be done with javascript after the plot has rendered.
Change the third circle into a triangle. This also needs to be done in javascript.
Changing the legend text
To do this manually, we could do p$x$data[[1]]$name <- "Fast", and replicate for each layer.
Fortunately, you have manually specified the legend order, making it easy to know where to access the correct legend names before passing to plotly. If we just do this step, it will create a legend which looks like this, i.e. still wrong (the first triangle should be a circle and neither should be have a color):
Changing the symbol shape and colors
We cannot do this in R. I have written an R helper function to generate some javascript to do this for us:
get_symbol_change_js <- function(symbol_nums,
new_color_string = "rgb(105, 105, 105)") {
js_get_legend <- htmltools::HTML(
'let legend = document.querySelector(".scrollbox");
let symbols = legend.getElementsByClassName("legendsymbols");
const re = new RegExp("fill: rgb.+;", "i");
'
)
change_symbol_color_code <- lapply(
symbol_nums,
\(i)
paste0(
"symbols[", i, "].innerHTML = ",
"symbols[", i, "].innerHTML.replace(re,",
' "fill: ', new_color_string, ';");'
)
) |>
paste(collapse = "\n")
# shape to change
shape_change_num <- symbol_nums[1]
# shape to replace with
shape_change_from <- shape_change_num - 1
change_symbols_shape_code <- paste0(
'const shape_re = new RegExp(\'d=".*?"\');\n',
"const correct_shape = symbols[", shape_change_from, "].innerHTML.match(shape_re)[0];\n",
"symbols[2].innerHTML = symbols[", shape_change_num, "].innerHTML.replace(shape_re, correct_shape);"
)
all_js <- htmltools::HTML(
unlist(c(
js_get_legend,
change_symbol_color_code,
change_symbols_shape_code
))
)
return(all_js)
}
We can put this all together to generate the plot as desired:
draw_plotly_with_legend(plt)
Final draw_plotly_with_legend() function
Note this function calls get_symbol_change_js(), as defined above. It also uses htmlwidgets::prependContent() to attach our custom html to the widget before rendering.
draw_plotly_with_legend <- function(gg = plt,
guide_types = c("colour", "shape")) {
# Period, Level
legend_categories <- lapply(
guide_types, \(x) rlang::quo_get_expr(plt$mapping[[x]])
)
new_legend_names <- lapply(legend_categories, \(category) {
unique(data[[category]])
}) |> setNames(guide_types)
# Work out which symbols need to have color removed
symbols_to_remove_color <- new_legend_names[
names(new_legend_names) != "colour"
] |> unlist()
new_legend_names <- unlist(new_legend_names)
symbol_num_remove_color <- which(
new_legend_names %in% symbols_to_remove_color
)
# Create plot
p <- ggplotly(gg, height = 500) %>%
layout(xaxis = list(autorange = "reversed"))
# Show legend
p$x$layout$showlegend <- TRUE
# Update legend names and put in one group
for (i in seq_along(p$x$data)) {
p$x$data[[i]]$name <- new_legend_names[i]
p$x$data[[1]]$legendgroup <- "Grouped legend"
}
# Get the js code to change legend color
# js is 0 indexed
js_symbol_nums <- symbol_num_remove_color - 1
js_code <- get_symbol_change_js(js_symbol_nums)
# Add it to the plot
p <- htmlwidgets::prependContent(
p,
htmlwidgets::onStaticRenderComplete(js_code)
)
return(p)
}
Package shinyscreenshot is not able to print plotly colorbars (shiny screenshot appears with colorless legend), so I'm looking for a way to still use color gradient but display the legend as if it were factorised.
Example
Origin plot with colorbar
Goal
It doesn't mattert if there are 4, 5 or X datapoints in legend.
MWE
library(ggplot2)
library(plotly)
ggplotly(
ggplot(data=mtcars,
aes(x=mpg, y=cyl, color=qsec)) +
geom_point()
)
Plotly won't make a discrete legend for you, but you can still make it happen.
First, I assigned both the ggplot and ggplotly to objects.
plt <- ggplotly(
ggplot(data=mtcars,
aes(x=mpg, y=cyl, color=qsec)) +
geom_point()
)
g <- ggplot(data=mtcars,
aes(x=mpg, y=cyl, color=qsec)) +
geom_point()
Next, use the data behind the ggplot object, combined with mtcars, to get a color by qsec data frame, so that you know what colors go with what values.
colByVal <- cbind(ggplot_build(g)$data[[1]], mtcars) %>%
as.data.frame() %>%
select(colour, qsec) %>% arrange(qsec) %>%
group_by(colour) %>%
summarise(qsec = median(qsec)) %>% as.data.frame()
I figured that four or five values would be ideal. I just used summary to pick them. However, that's not necessary. Obviously, you can choose however many values you would like. These are the values I'll show in the legend.
parts <- summary(colByVal$qsec)
# drop the mean or median (the same color probably)
parts <- parts[-4]
Next, use DescTools::Closest to find the qsec values closest to the summary values.
vals <- lapply(parts, function(k) {
DescTools::Closest(colByVal$qsec, k)[1]
}) %>% unlist(use.names = F)
Use these qsec values and the data frame with value by color to get the colors associated with these values.
cols <- colByVal %>%
filter(qsec %in% vals) %>% select(colour) %>%
unlist(use.names = F)
Using the colors and values (legend labels), use shapes and annotations (circles and text) to rebuild the legend. There is only one other element that needs to change between each legend item, the y position of the legend entry.
ys <- seq(from = .7, by = .07, length.out = length(cols))
There are two functions: shapes and annotations. Using lapply, walk through the values, colors, and y values through these functions to create the shapes and annotations.
# create shapes
shp <- function(y, cr) { # y0, and fillcolor
list(type = "circle",
xref = "paper", x0 = 1.1, x1 = 1.125,
yref = "paper", y0 = y, y1 = y + .025,
fillcolor = cr, yanchor = "center",
line = list(color = cr))
}
# create labels
ano <- function(ya, lab) { # y and label
list(x = 1.13, y = ya + .035, text = lab,
xref = "paper", yref = "paper",
xanchor = "left", yanchor = 'top',
showarrow = F)
}
# the shapes list
shps <- lapply(1:length(cols),
function(j) {
shp(ys[j], cols[j])
})
# the labels list
labs <- lapply(1:length(cols),
function(i) {
ano(ys[i], as.character(vals[i]))
})
When you use ggplotly, for some reason it ends an empty shape to the ggplotly object. This interferes with the ability to call for shapes in layout (which is the proper method). You have to force the issue with shapes. Additionally, the legend bar needs to go away. Once you drop the legend bar, Plotly will adjust the plot margins. The legend created with shapes and annotations will be hidden if you don't add the margins back.
# ggplot > ggplotly adds an empty shape; this conflicts with calling it in
# layout(); we'll replace 'shapes' first
plt$x$layout$shapes <- shps
plt %>% hide_colorbar() %>%
layout(annotations = labs, showlegend = F,
margin = list(t = 30, r = 100, l = 50, b = 30, pad = 3))
All of that code in one chunk:
library(tidyverse)
library(plotly)
# original plot
plt <- ggplotly(
ggplot(data=mtcars,
aes(x=mpg, y=cyl, color=qsec)) +
geom_point()
)
g <- ggplot(data=mtcars,
aes(x=mpg, y=cyl, color=qsec)) +
geom_point()
# color by qsec values frame
colByVal <- cbind(ggplot_build(g)$data[[1]], mtcars) %>%
as.data.frame() %>%
select(colour, qsec) %>% arrange(qsec) %>%
group_by(colour) %>%
summarise(qsec = median(qsec)) %>% as.data.frame()
parts <- summary(colByVal$qsec)
# drop the mean or median (the same color probably)
parts <- parts[-4]
vals <- lapply(parts, function(k) {
DescTools::Closest(colByVal$qsec, k)[1]
}) %>% unlist(use.names = F)
cols <- colByVal %>%
filter(qsec %in% vals) %>% select(colour) %>%
unlist(use.names = F)
ys <- seq(from = .7, by = .07, length.out = length(cols))
# create shapes
shp <- function(y, cr) { # y0, and fillcolor
list(type = "circle",
xref = "paper", x0 = 1.1, x1 = 1.125,
yref = "paper", y0 = y, y1 = y + .025,
fillcolor = cr, yanchor = "center",
line = list(color = cr))
}
# create labels
ano <- function(ya, lab) { # y and label
list(x = 1.13, y = ya + .035, text = lab,
xref = "paper", yref = "paper",
xanchor = "left", yanchor = 'top',
showarrow = F)
}
# the shapes list
shps <- lapply(1:length(cols),
function(j) {
shp(ys[j], cols[j])
})
# the labels list
labs <- lapply(1:length(cols),
function(i) {
ano(ys[i], as.character(vals[i]))
})
# ggplot > ggplotly adds an empty shape; this conflicts with calling it in
# layout(); we'll replace 'shapes' first
plt$x$layout$shapes <- shps
plt %>% hide_colorbar() %>%
layout(annotations = labs, showlegend = F,
margin = list(t = 30, r = 100, l = 50, b = 30, pad = 3))
This is only a partial answer; you can change the shape and text of the legend while maintaining its gradient by using a combination of scale_color_continuous and guides(color = guide_legend()), but this will only show up as a ggplot object. For some reason, the legend disappears when you add the plot to ggplotly(), the legend disappears. I suspect that arguments specific to the legend may need to be added to ggplotly() directly.
library(tidyverse)
library(plotly)
data(mtcars)
p <- ggplot(mtcars, aes(x = mpg, y = cyl, color = qsec)) +
geom_point() +
scale_color_continuous(breaks = c(15, 17.5, 20, 22.5)) +
guides(color = guide_legend(
reverse = T,
override.aes = list(shape = 19, size = 8))) +
theme(legend.position = "right")
p
p2 <- ggplotly(p) %>% layout(showlegend = T)
p2
I have created the following dataframe object and graph using plotly and ggplot
library(ggplot2)
library(plotly)
rdate <- function(x,
min = paste0(format(Sys.Date(), '%Y'), '-01-01'),
max = paste0(format(Sys.Date(), '%Y'), '-12-31'),
sort = TRUE) {
dates <- sample(seq(as.Date(min), as.Date(max), by = "day"), x, replace=TRUE)
if (sort == TRUE) {
sort(dates)
} else {
dates
}
}
DF<-data.frame(Date = rdate(100))
DF$variable<-LETTERS[seq( from = 1, to = 10 )]
DF$Value<-round(runif(1:nrow(DF),min = 10, max = 50))
Next I have created a plot object with ggplot
p <- ggplot(DF, aes(x = Date, y = Value, colour = variable)) +
geom_line() +
ylab(label="Sellcount") +
xlab("Sell Week")
p<-p + scale_y_continuous(sec.axis = dup_axis())
ggplotly(p)
IF i plot p using plot(p), the graph has 2 yaxes as I expect. However, when I use ggplotly(p) to plot the graph, only one Y axis is generated. I am unable to find any literature on the internet regarding the same. I request someone to help me in this.
A simple workaround is to add the second axis manually:
ay <- list(
tickfont = list(size=11.7),
titlefont=list(size=14.6),
overlaying = "y",
nticks = 5,
side = "right",
title = "Second y axis"
)
ggplotly(p) %>%
add_lines(x=~Date, y=~Value, colors=NULL, yaxis="y2",
data=DF, showlegend=FALSE, inherit=FALSE) %>%
layout(yaxis2 = ay)
I have a dataframe:
gene_symbol<-c("DADA","SDAASD","SADDSD","SDADD","ASDAD","XCVXCVX","EQWESDA","DASDADS","SDASDASD","DADADASD","sdaadfd","DFSD","SADADDAD","SADDADADA","DADSADSASDWQ","SDADASDAD","ASD","DSADD")
panel<-c("growth","growth","growth","growth","big","big","big","small","small","dfgh","DF","DF","DF","DF","DF","gh","DF","DF")
ASDDA<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
ASDDb<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
ASDDAf<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
ASDDAf1<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
ASDDAf2<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
ASDDAf3<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
ASDDAf4<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
ASDDAf5<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
ASDDA1<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
ASDDb1<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
ASDDAf1<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
ASDDAf11<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
ASDDAf21<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
ASDDAf31<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
ASDDAf41<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
ASDDAf51<-c("normal","over","low","over","normal","over","low","over","normal","over","DF","DF","DF","DF","DF","DF","DF","DF")
Gene_states22 <- data.frame(gene_symbol, panel, ASDDA, ASDDb, ASDDAf, ASDDAf1, ASDDAf2,
ASDDAf3, ASDDAf4, ASDDAf5, ASDDA1, ASDDb1, ASDDAf1, ASDDAf11,
ASDDAf21, ASDDAf31, ASDDAf41, ASDDAf51)
And I create a heatmap with:
library(ggplot2); library(reshape2)
HG3 <- split(Gene_states22[,1:15], Gene_states22$panel)
HG4 <- melt(HG3, id.vars= c("gene_symbol","panel"))
HG4 <- HG4[,-5]
pp <- ggplot(HG4, aes(gene_symbol,variable)) +
geom_tile(aes(fill = value),
colour = "grey50") +
facet_grid(~panel, scales = "free" ,space = "free") +
scale_fill_manual(values = c("white", "red", "blue", "black", "yellow", "green", "brown"))
As you can see I use facet_grid to separate my heatmap into groups based on panel value. The problem is that when I use ggplotly(pp) the column width differs from group to group and my plot seems ugly.
In order to fix the issue I used adapted answer of Plotly and ggplot with facet_grid in R: How to to get yaxis labels to use ticktext value instead of range value?
:
library(plotly)
library(ggplot2)
library(data.table)
library(datasets)
#add fake model for use in facet
dt<-data.table(HG4[1:50,])
dt[,variable:=rownames(HG4)]
dt[,panel:=substr(variable,1,regexpr(" ",variable)-1)][panel=="",panel:=variable]
ggplot.test<-ggplot(dt,aes(gene_symbol,variable))+facet_grid(panel~.,scales="free_y",space="free",drop=TRUE)+
geom_tile(aes(fill = value),
colour = "grey50") +
scale_fill_manual(values = c("white", "red", "blue", "black", "yellow", "green", "brown")) +
labs(title = "Heatmap", x = "gene_symbol", y = "sample", fill = "value") +
guides(fill = FALSE)+
theme(panel.background = element_rect(fill = NA),
panel.spacing = unit(0.5, "lines"), ## It was here where you had a 0 for distance between facets. I replaced it by 0.5 .
strip.placement = "outside")
p <- ggplotly(ggplot.test)
len <- length(unique(HG4$panel))
total <- 1
for (i in 2:len) {
total <- total + length(p[['x']][['layout']][[paste('yaxis', i, sep='')]][['ticktext']])
}
spacer <- 0.01 #space between the horizontal plots
total_length = total + len * spacer
end <- 1
start <- 1
for (i in c('', seq(2, len))) {
tick_l <- length(p[['x']][['layout']][[paste('yaxis', i, sep='')]][['ticktext']]) + 1
#fix the y-axis
p[['x']][['layout']][[paste('yaxis', i, sep='')]][['tickvals']] <- seq(1, tick_l)
p[['x']][['layout']][[paste('yaxis', i, sep='')]][['ticktext']][[tick_l]] <- ''
end <- start - spacer
start <- start - (tick_l - 1) / total_length
v <- c(start, end)
#fix the size
p[['x']][['layout']][[paste('yaxis', i, sep='')]]$domain <- v
}
p[['x']][['layout']][['annotations']][[3]][['y']] <- (p[['x']][['layout']][['yaxis']]$domain[2] + p[['x']][['layout']][['yaxis']]$domain[1]) /2
p[['x']][['layout']][['shapes']][[2]][['y0']] <- p[['x']][['layout']][['yaxis']]$domain[1]
p[['x']][['layout']][['shapes']][[2]][['y1']] <- p[['x']][['layout']][['yaxis']]$domain[2]
#fix the annotations
for (i in 3:len + 1) {
#fix the y position
p[['x']][['layout']][['annotations']][[i]][['y']] <- (p[['x']][['layout']][[paste('yaxis', i - 2, sep='')]]$domain[1] + p[['x']][['layout']][[paste('yaxis', i - 2, sep='')]]$domain[2]) /2
#trim the text
p[['x']][['layout']][['annotations']][[i]][['text']] <- substr(p[['x']][['layout']][['annotations']][[i]][['text']], 1, length(p[['x']][['layout']][[paste('yaxis', i - 2, sep='')]][['ticktext']]) * 3 - 3)
}
#fix the rectangle shapes in the background
for (i in seq(0,(len - 2) * 2, 2)) {
p[['x']][['layout']][['shapes']][[i+4]][['y0']] <- p[['x']][['layout']][[paste('yaxis', i /2 + 2, sep='')]]$domain[1]
p[['x']][['layout']][['shapes']][[i+4]][['y1']] <- p[['x']][['layout']][[paste('yaxis', i /2 + 2, sep='')]]$domain[2]
}
p
But the heatmap is still not correct:
So first things first:
In your case I am not even sure whether a plotly heatmap is what you need. In addition you should never convert a complicated ggplot to plotly. It will fail! In 90% of cases. Try recreating your plot in plotly or whereever you want it to end up. Anything else ends up in coding hell.
I started by doing some research:
Here is a good description how to create heatmaps with different colors in plotly
This explains how you can create titles in subplots.
From post 1 I know that I have to create a matrix for each level in your data. So I wrote a function for that:
mymat<-as.matrix(Gene_states22[,-1:-2])
### Creates a 1-NA dummy matrix for each level. The output is stored in a list
dummy_mat<-function(mat,levels,names_col){
mat_list<-lapply(levels,function(x){
mat[mat!=x]=NA
mat[mat==x]=1
mymat=t(apply(mat,2,as.numeric))
colnames(mymat)=names_col
return(mymat)
})
names(mat_list)=levels
return(mat_list)
}
my_mat_list<-dummy_mat(mymat,c('DF','low','normal','over'),Gene_states22$gene_symbol)
### Optional: The heatmap type is peculiar - I created a text-NA matrix for each category as well
text_mat<-function(mat,levels,names_col){
mat_list<-lapply(levels,function(x){
mat[mat!=x]=NA
mat=t(mat)
colnames(mat)=names_col
return(mat)
})
names(mat_list)=levels
return(mat_list)
}
my_mat_list_t<-text_mat(mymat,c('DF','low','normal','over'),as.character(Gene_states22$gene_symbol))
In addition I needed colors for each level. These colors are created using some dataframe. You may write a similar (lapply-)loop here as well:
DF_Color <- data.frame(x = c(0,1), y = c("#DEDEDE", "#DEDEDE"))
colnames(DF_Color) <- NULL
lowColor <- data.frame(x = c(0,1), y = c("#00CCFF", "#00CCFF"))
colnames(lowColor) <- NULL
normColor <- data.frame(x = c(0,1), y = c("#DEDE00", "#DEDE00"))
colnames(normColor) <- NULL
overColor <- data.frame(x = c(0,1), y = c("#DE3333", "#DE3333"))
colnames(overColor) <- NULL
In addition we need the columns in the matrix for each panel-category:
mycols<-lapply(levels(Gene_states22$panel),function(x) grep(x,Gene_states22$panel))
I stored this in a list as well.
Next I use lapply-loop to plot. I store the values in a list and use subplot to put everything together:
library(plotly)
p_list<-lapply(1:length(mycols),function(j){
columns<-mycols[[j]]
p<-plot_ly(
type = "heatmap"
) %>% add_trace(
y=rownames(my_mat_list$DF),x=colnames(my_mat_list$DF)[columns],
z = my_mat_list$DF[,columns],
xgap=3,ygap=3, text=my_mat_list_t$DF[,columns],hoverinfo="x+y+text",
colorscale = DF_Color,
colorbar = list(
len = 0.3,
y = 0.3,
yanchor = 'top',
title = 'DF series',
tickvals = ''
)
) %>% add_trace(
y=rownames(my_mat_list$low),x=colnames(my_mat_list$low)[columns],
z = my_mat_list$low[,columns],
xgap=3,ygap=3,text=my_mat_list_t$low[,columns],hoverinfo="x+y+text",
colorscale = lowColor,
colorbar = list(
len = 0.3,
y = 0.3,
yanchor = 'top',
title = 'low series',
tickvals = ''
)
) %>% add_trace(
y=rownames(my_mat_list$normal),x=colnames(my_mat_list$normal)[columns],
z = my_mat_list$normal[,columns],
xgap=3,ygap=3,text=my_mat_list_t$normal[,columns],hoverinfo="x+y+text",
colorscale = normColor,
colorbar = list(
len = 0.3,
y = 1,
yanchor = 'top',
title = 'normal series',
tickvals = ''
)
) %>% add_trace(
y=rownames(my_mat_list$over),x=colnames(my_mat_list$over)[columns],
z = my_mat_list$over[,columns],
xgap=3,ygap=3,text=my_mat_list_t$over[,columns],hoverinfo="x+y+text",
colorscale = overColor,
colorbar = list(
len = 0.3,
y = 1,
yanchor = 'top',
title = 'over series',
tickvals = ''
)
)
return(p)
})
subplot(p_list[[1]],p_list[[2]],shareY = TRUE) %>%
layout(annotations = list(
list(x = 0.2 , y = 1.05, text = levels(Gene_states22$panel)[1], showarrow = F, xref='paper', yref='paper'),
list(x = 0.8 , y = 1.05, text = levels(Gene_states22$panel)[2], showarrow = F, xref='paper', yref='paper'))
)
POSSIBLE ISSUES:
You have to become create around categories like dfgh which occur only once. If only one column is selected in R, the output is automatically transformed into a (numeric or character) vector-type. Thus maybe add an as.matrix() to all z and text arguments
hover-text doesn't really work. But plotly has a good documentation there. You should be able to figure that out.
You also have to specify the width in the subplot-function. That will be fiddly if you have more than 10 categories.
Interactivity doesn't really work. You can't remove traces. Why? No idea. Do some research if you need it. I guess it is connected with the plot type.
I recommend specifying the extend of the plot(s) in px. That might make the tiles more similar.
Finally you will need some reference for the (subplot) titles and you will need to adjust the margins of your plot. Such that the titles are visible.
The purpose of the code is to produce an interactive plotly chart with shaded vertical areas on specified subsets on X-axis.
The first step is to construct a ggplot2 object, with shaded vertical areas constructed using geom_rect, then use ggplotly to produce a plotly object.
Since ggplotly does not produce an output which contains the shaded vertical areas anymore, I am adding them to ggplotly output (which is is a plotly object) by using plotly function add_lines.
However, this approach does not work. The approach that works is to start from a natively-built plotly object and then using plotly function add_lines.
Does this mean that output from ggplotly is not a full-featured plotly object?
The reproducible example is below. One can change values of logical variables useOnlyPlotly (line 67) and useGeomRect (line 66) to see the behaviors described above
require(tidyverse)
require(plotly)
require(lubridate)
plotShadedAreaUsingGeomBarsFunc <- function(colorArea, dataY){
ggplot2::geom_bar(data = trimmedRecessionsDates, inherit.aes = FALSE,
aes_(x = quote(MidPoint), y = base::max(dataY)), # y = Inf doesn't work
stat = "identity",width = 0.1,
# position = "stack",
fill = colorArea, alpha = 0.2)
}
plotShadedAreaUsingGeomRectFunc <- function(colorArea, dataY){
ggplot2::geom_rect(data = trimmedRecessionsDates, inherit.aes = FALSE,
aes(xmin = as.Date(Peak), xmax = as.Date(Trough), ymin = -Inf, ymax = +Inf),
fill = colorArea,
alpha = 0.2)
}
# dates
dateOne <- lubridate::ymd("2000-1-1")
dateTwo <- lubridate::ymd("2004-1-1")
dateThree <- lubridate::ymd("2009-1-1")
dateFour <- lubridate::ymd("2013-1-1")
dateFive <- lubridate::ymd("2017-12-31")
PeakDates <- c(lubridate::ymd("2001-03-01"), lubridate::ymd("2007-12-01"))
TroughDates <- c(lubridate::ymd("2001-11-01"), lubridate::ymd("2008-08-31"))
sequenceDates <- seq(dateOne, dateFive, by="month")
sequenceInRecession <- c(rep(0,length(sequenceDates)))
sequenceInRecession <- base::replace(sequenceInRecession, list = c(15,16,17,18,19,20,21,22,23,96,97,98,99,100), values = c(rep(1,14)))
sequenceInRecession <- base::replace(sequenceInRecession, list = c(101,102,103,104,105,106,107,108,109,110,111,112,113,114), values = c(rep(1,14)))
dataFrameRecessionDates <- data.frame(Dates = sequenceDates, InRecession = sequenceInRecession)
dataFrameRecessionDates$Dates <- lubridate::as_date(dataFrameRecessionDates$Dates)
#data
theDataFrame <- data.frame(Dates = c(dateOne, dateTwo, dateThree, dateFour, dateFive), SomeValues = c(0.2, 2.8, 4.5, 9.8, -0.3),
season = c("SeasOne","SeasTwo","SeasOne","SeasOne","SeasTwo"))
trimmedRecessionsDates <- data.frame(Peak = PeakDates, Trough = TroughDates)
# define midPoint as middle point between Peak and Trough
trimmedRecessionsDates$MidPoint = trimmedRecessionsDates$Peak + floor((trimmedRecessionsDates$Trough - trimmedRecessionsDates$Peak)/2)
trimmedRecessionsDates$MidPoint <- base::as.Date(trimmedRecessionsDates$MidPoint)
colNamesDataFrame <- colnames(theDataFrame)[2:2]
valMax <- base::max(sapply(theDataFrame[colNamesDataFrame], max, na.rm = TRUE))
valMin <- base::min(sapply(theDataFrame[colNamesDataFrame], min, na.rm = TRUE))
dataFrameRecessionDates$InRecession[dataFrameRecessionDates$InRecession %in% 1] <- valMax + 0.2*base::abs(valMax)
dataFrameRecessionDates$InRecession[dataFrameRecessionDates$InRecession %in% 0] <- valMin - 0.2*base::abs(valMin)
ggplotObjUsingGeomBar <- ggplot2::ggplot(data = theDataFrame, aes(x = Dates, y = SomeValues, color = season)) +
ggplot2::geom_line() +
plotShadedAreaUsingGeomBarsFunc('turquoise3', theDataFrame$SomeValues)
ggplotObjUsingGeomRect <- ggplot2::ggplot(data = theDataFrame, aes(x = Dates, y = SomeValues)) +
ggplot2::geom_line() +
plotShadedAreaUsingGeomRectFunc('turquoise3', theDataFrame$SomeValues)+
ggplot2::theme_bw()
useGeomRect = TRUE
useOnlyPlotly = TRUE
thePlotlyObjToAnalyze <- plot_ly()
if (useOnlyPlotly)
{
thePlotlyObjToAnalyze <- plot_ly(data = theDataFrame, x = ~Dates, y = ~SomeValues) %>%
add_lines(data = theDataFrame, x = ~Dates, y = ~SomeValues,
line = list(width = 3), hoverinfo = "x + y")
} else {
if (useGeomRect)
{
thePlotlyObjToAnalyze <- hide_legend(ggplotly(ggplotObjUsingGeomRect))
} else {
thePlotlyObjToAnalyze <- hide_legend(ggplotly(ggplotObjUsingGeomBar))
}
}
(thePlotlyObjToAnalyze %>%
plotly::add_lines(data = dataFrameRecessionDates,
x = ~Dates, y = ~InRecession,
line = list(width = 0),
fill = "tozerox",
fillcolor = "rgba(64, 64, 64, 0.3)",
showlegend = F,
hoverinfo = "none"))
Update: Below is code based on answer provided in enter link description here, but unfortunately it did not work for me
library(plotly)
library(ggplot2)
useOnlyPlotly <- FALSE
thePlot <- plot_ly()
if (useOnlyPlotly)
{
thePlot <- plot_ly() %>%
add_trace(data = economics, x = ~date, y = ~unemploy, type="scatter", mode = "lines")
}else{
theGgplot2Obj <- ggplot(data = economics, aes(x = date, y = unemploy)) + geom_line()
thePlot <- ggplotly(theGgplot2Obj)
thePlot[['x']][['layout']][['shapes']] <- c()
}
( thePlot <- layout(thePlot,
shapes = list(
list(type = "rect",
fillcolor = "blue", line = list(color = "blue"), opacity = 0.5,
x0 = "1980-01-01", x1 = "1990-01-01",
y0 = 6000, y1 = 8000
)
)
)
)
Your idea of using add_lines combined with filltozero is good but the gaps between your shades will be problematic, you would probably need to add NaN in between to get it right.
The real problem is that your input dates are strings and Plotly stores the dates as integers (milliseconds since the epoch). So we would need to convert the dates first and then plot them.
x0 = as.integer(as.POSIXct(trimmedRecessionsDates$Peak[[i]])) * 1000
thePlotlyObjToAnalyze$x$layout$shape <- c()
shapes = list()
for (i in 1:length(trimmedRecessionsDates$MidPoint)) {
shapes[[i]] = list(type = "rect",
fillcolor = "blue", line = list(color = "blue"), opacity = 0.5,
x0 = as.integer(as.POSIXct(trimmedRecessionsDates$Peak[[i]])) * 1000,
x1 = as.integer(as.POSIXct(trimmedRecessionsDates$Trough[[i]])) * 1000,
y0 = 0,
y1 = 1,
yref = 'paper'
)
}
thePlotlyObjToAnalyze <- layout(thePlotlyObjToAnalyze,
shapes = shapes
)