I created a kind of interactive calendar heatmap using the following code. It is quite long but should be reproducible.
library(plotly)
library(data.table)
library(tidyr)
library(htmlwidgets)
library(widgetframe)
df <- data.frame(dom = sequence(31,1,1),
Januar= sample(50:500, 31),
Februar = sample(50:500, 31),
März =sample(50:500, 31),
April = sample(50:500, 31),
Mai = sample(50:500, 31))
df <- as.data.table(df)
df<- melt(df, id.vars= "dom",variable.name="month",value.name="value", na.rm=T)
df<- as.data.frame(df)
df <- df %>% mutate(month= factor(month,levels=as.character(c("Januar","Februar","März","April","Mai")),labels=c("Jan","Feb","Mär","Apr","Mai"),ordered=TRUE))
df$dommapped <- ordered(df$dom, levels = 31:1)
df <- df%>% mutate(group=ceiling(value/(max(value)/5)))
df$group_1<- ifelse(df$group==1,df$group,NA)
df$group_2<- ifelse(df$group==2,df$group,NA)
df$group_3<- ifelse(df$group==3,df$group,NA)
df$group_4<- ifelse(df$group==4,df$group,NA)
df$group_5<- ifelse(df$group==5,df$group,NA)
colorScale1 <- data.frame(z=c(0,1),col=c("#FFE27a","#FFE27a"))
colorScale1$col <- as.character(colorScale1$col)
colorScale2 <- data.frame(z=c(0,1),col=c("#FFCD0e","#FFCD0e"))
colorScale2$col <- as.character(colorScale2$col)
colorScale3 <- data.frame(z=c(0,1),col=c("#A1C863","#A1C863"))
colorScale3$col <- as.character(colorScale3$col)
colorScale4 <- data.frame(z=c(0,1),col=c("#76B82b","#76B82b"))
colorScale4$col <- as.character(colorScale4$col)
colorScale5 <- data.frame(z=c(0,1),col=c("#4A731c","#4A731c"))
colorScale5$col <- as.character(colorScale5$col)
f1=list(family = "Arial, sans-serif",
size = 12,
color = "#000000")
f2 <- list(family = "Arial, sans-serif",
size = 14,
color = "#000000")
plot<-df%>%
plot_ly(.,y = ~month, x = ~dommapped, z=~group_1, text=~value,name="group1", type="heatmap", xgap=2, ygap=2,hovertemplate=" <extra>%{y}. %{x}: Ø %{text} cases</extra>",
hoverongaps=FALSE,colorscale=colorScale1,showlegend=TRUE, showscale=FALSE) %>%
add_trace(.,y = ~month, x = ~dommapped, z=~group_2, text=~value,name="group2", type="heatmap", xgap=2, ygap=2,hovertemplate=" <extra>%{y}. %{x}: Ø %{text} cases</extra>",
hoverongaps=FALSE,colorscale=colorScale2,showlegend=TRUE, showscale=FALSE) %>%
add_trace(.,y = ~month, x = ~dommapped, z=~group_3, text=~value,name="group3", type="heatmap", xgap=2, ygap=2,hovertemplate=" <extra>%{y}. %{x}: Ø %{text} cases</extra>",
hoverongaps=FALSE,colorscale=colorScale3,showlegend=TRUE, showscale=FALSE) %>%
add_trace(.,y = ~month, x = ~dommapped, z=~group_4, text=~value,name="group4",type="heatmap", xgap=2, ygap=2,hovertemplate=" <extra>%{y}. %{x}: Ø %{text} cases</extra>",
hoverongaps=FALSE,colorscale=colorScale4,showlegend=TRUE, showscale=FALSE) %>%
add_trace(.,y = ~month, x = ~dommapped, z=~group_5, text=~value,name="group5", type="heatmap", xgap=2, ygap=2,hovertemplate=" <extra>%{y}. %{x}: Ø %{text} cases</extra>",
hoverongaps=FALSE,colorscale=colorScale5,showlegend=TRUE, showscale=FALSE)
plot<-plot %>%
layout(title =list(text= "Very long title about content of graph",
xref = "paper",
x = 0,
font = f2),
hoverlabel=list(bgcolor="#ffffff",
bordercolor ="#ffffff",
font=f2),
showlegend = TRUE,
separators = ', ',
plot_bgcolor='#ffffff',
legend=list(itemclick="toggleothers",
orientation="h",
title=list(font=f1,
text="title"),
yanchor="top",
y=-0.25),
modebar = list(color = "#a3a3a3",
activecolor = "#000000"),
xaxis = list(title = "Day of month",
zeroline = FALSE,
gridcolor = 'ffff',
autorange = "reversed",
constraintoward="left"),
yaxis = list(title="month",zeroline = FALSE,gridcolor = 'ffff',autorange = "reversed",
scaleanchor="x", constraintoward = "bottom"))
plot<- plot %>% config(modeBarButtonsToRemove = list('autoScale2d'))
plot<- plot %>% config(locale='de')
plot<- plot %>% config(toImageButtonOptions = list(format = "png",filename = "",width = 760,height = 600))
plot<- plot %>% onRender("function(el, x) {Plotly.d3.select('.cursor-crosshair').style('cursor', 'default')}")
plot$sizingPolicy$browser$padding <- 0
htmlwidgets::saveWidget(title = "plot", frameableWidget(plot), "directory/plot_1.html")
The scaleanchor and constraintoward commands help to get the design I need. Otherwise the boxes wouldn't be square format.
But it leads - depending on the browser window size - a big white space between graph and title.
Setting the range for the yaxis does not work.
Setting the margin also didn't work so far.
I thought I have to find a solution without scaleanchor and constraintoward to get the needed aspect ratio. So I tried to change the layout by using aspectratio and aspectmode.
layout(title =list(text= "Very long title about content of graph",
xref = "paper",
x = 0,
font = f2),
hoverlabel=list(bgcolor="#ffffff",
bordercolor ="#ffffff",
font=f2),
showlegend = TRUE,
separators = ', ',
plot_bgcolor='#ffffff',
legend=list(itemclick="toggleothers",
orientation="h",
title=list(font=f1,
text="title"),
yanchor="top",
y=-0.25),
modebar = list(color = "#a3a3a3",
activecolor = "#000000"),
xaxis = list(title = "Day of month",
zeroline = FALSE,
gridcolor = 'ffff',
autorange = "reversed"),
yaxis = list(title="month",zeroline = FALSE,gridcolor = 'ffff',autorange = "reversed"),
scene=list(aspectmode="manual",
aspectratio=list(x=3,
y=1)))
But this also didn't work. I would be happy, if someone has an other idea or solution for this problem.
I figured out a solution for my problem.
By changing in layout for yaxis the key constraintoward to constraintoward = "top" and adding constrain="domain" I get the effect I need.
So the code for the yaxis-layout looks like this:
layout(yaxis = list(title="month",
zeroline = FALSE,
gridcolor = 'ffff',
autorange = "reversed",
scaleanchor="x",
constraintoward = "top",
constrain="domain"))