How to improve speed of ggplot bar chart when plotting >1000 points? - r

Question

I'm producing a bar chart for 1200 observations using ggplot2. Each of these observations has an error bar. There's also an average shown (using geom_line) for these observations overall.
I'm finding the running time is very slow (2 seconds) in comparison to less observations (e.g. if 500 or were used <1 second). Also, all observations must be a seperate bar.
I realise it doesn't sound like much time, but this time adds up overall for what I need to do - producing over 100 of these plots and knitting them to rmd file.
Below is a piece of code I've created to replicate the issue - this is using ggplot2 inbuilt diamonds dataset.
diamonds1 <- as.data.frame(mutate(diamonds, upper = x + 1.2, lower = x - 0.4))
diamonds2 <- diamonds1 %>%
group_by(cut) %>%
summarize(Mean = mean(x, na.rm=TRUE))
ChosenColorClarity <- "VVS28451"
diamonds3 <- left_join(diamonds1 ,diamonds2, by = c("cut" = "cut") ) %>%
filter(cut == "Very Good") %>%
mutate(ID = paste0(clarity,row_number() )) %>%
mutate(CutType = case_when(ID==ChosenColorClarity ~ ID,
color == "F" & ID != ChosenColorClarity ~ " Same Color",
TRUE ~ " Other Color"),
CutLabel = ifelse(ID == ChosenColorClarity, "Your Cut", ""))
diamonds4 <- diamonds3[order(-xtfrm(diamonds3$CutLabel)),]
diamonds4 <- diamonds4[1:1255,]
diamonds4$Xval <- as.numeric(reorder(diamonds4$ID, diamonds4$x))
DiamondCutChart = diamonds4 %>%
ggplot(aes(x = Xval,
y = x)) +
geom_bar(aes(fill=CutType), stat = "identity", width = 1) +
geom_errorbar(aes(ymin = lower, ymax = upper)) +
geom_text(aes(label = CutLabel),
position = position_stack(vjust = 0.5),
size = 2.7, angle = 90, fontface = "bold") +
geom_line(aes(y = diamonds4$Mean), group = 1, linetype=2, colour = "#0000ff") +
scale_fill_manual(values = c("#32572C", "#41B1B1", "#db03fc")) +
annotate("text", x = 1, y = diamonds4$Mean, hjust =0, vjust = -0.5,
size = 3.2, colour = "#0000ff",
label=paste0("Mean ",diamonds4$Mean)) +
theme_classic()+
theme(axis.title.x=element_blank(),
axis.title.y=element_blank(),
axis.text.x=element_blank(),
axis.ticks.x=element_blank(),
legend.position = "top") +
labs(fill = "")
StartTime = Sys.time()
DiamondCutChart
EndTime = Sys.time()
EndTime - StartTime
When running this, it takes around 2 seconds. I need this to be less than 1 second to be able to produce multiple plots and rmarkdown outputs in less overall time.
How can I reduce the time it takes to plot the graph from the piece of code?
Any help or pointing in the right direction is greatly appreciated.

Answer 1

I'm assuming for now that you're aiming for raw speed, and visualization that depicts the desired data content. I'm not sure you need geom_bar() if only one bar is a different color. If your real world scenario has 7 different colors mixed randomly among the 1255 bars... this workaround won't work for you. :) Hopefully this will be helpful! :)
The geom_ribbon() is much faster to render than geom_bar(). With 1255 positions I didn't fiddle with its options, but I understand it has step functions to make it appear like bars when zoomed in. Ymmv.
It is so much faster, I decided to use it twice: once to render "bars" and once to render "error bars". In order for geom_ribbon() to work (for me) I created a numeric column for the x-axis values Xval, see below.
The geom_text() step is really only printing one label, and subsetting the data during this step saves a lot of rendering time. You can adjust as needed.
Same with the annotate() step, it's actually printing and re-printing the same label 1255 times, takes a lot of time. Obviously you don't need that. :)
Each of the three steps above saves about 0.6 to 0.7 seconds. Maybe you can mix and match with other geoms as needed.
The final result (on my system) was 0.2 seconds.
diamonds4$Xval <- as.numeric(reorder(diamonds4$ID, diamonds4$x))
DiamondCutChartNew <- diamonds4 %>%
ggplot(aes(x = Xval, y = x)) +
geom_ribbon(aes(ymin = 0, ymax = x), fill="#32572C") +
geom_col(data = subset(diamonds4, nchar(CutLabel) > 0),
aes(x = Xval, y = x),
fill = "#41B1B1") +
geom_ribbon(data = diamonds4,
aes(ymin = lower, ymax = upper), fill="#FF000077") +
geom_line(aes(y = x)) +
geom_text(data = subset(diamonds4, nchar(CutLabel) > 0),
aes(label = CutLabel),
position = position_stack(vjust = 0.5),
size = 2.7, angle = 90, fontface = "bold") +
geom_line(aes(x = Xval, y = Mean), group = 1, linetype = 2, colour = "#0000ff") +
annotate("text", x = 1, y = head(diamonds4$Mean, 1), hjust = 0, vjust = -0.5,
size = 3.2, colour = "#0000ff",
label=paste0("Mean ", head(diamonds4$Mean, 1))) +
theme_classic() +
theme(axis.title.x=element_blank(),
axis.title.y=element_blank(),
axis.text.x=element_blank(),
axis.ticks.x=element_blank(),
legend.position = "top") +
labs(fill = "")
{StartTime = Sys.time()
print(DiamondCutChartNew)
EndTime = Sys.time()
EndTime - StartTime}
Original result (for me):
Time difference of 2.05 secs
The new result:
Time difference of 0.229 secs

Answer 2

Pasting the ProfVis run for this question:
https://rstudio.github.io/profvis/
install.packages("profvis")
library(profvis)
profvis(expr = {
DiamondCutChart <- diamonds4 %>%
ggplot(aes(x = reorder(ID, x),
y = x)) +
geom_bar(aes(fill=CutType), stat = "identity", width = 1) +
geom_errorbar(aes(ymin = lower, ymax = upper)) +
geom_text(aes(label = CutLabel),
position = position_stack(vjust = 0.5),
size = 2.7, angle = 90, fontface = "bold") +
geom_line(aes(y = Mean), group = 1, linetype=2, colour = "#0000ff") +
scale_fill_manual(values = c("#32572C", "#41B1B1")) +
annotate("text", x = 1, y = diamonds4$Mean, hjust =0, vjust = -0.5,
size = 3.2, colour = "#0000ff",
label=paste0("Mean ",diamonds4$Mean)) +
theme_classic()+
theme(axis.title.x=element_blank(),
axis.title.y=element_blank(),
axis.text.x=element_blank(),
axis.ticks.x=element_blank(),
legend.position = "top") +
labs(fill = "")
print(DiamondCutChart)
},
interval = 0.005
)