Related
I am new to cartogram, geospatial & gganimate and was recreating animated plot by using code from website: https://www.r-graph-gallery.com/a-smooth-transition-between-chloropleth-and-cartogram.html
But at the last step of animating I am now getting this error:
Error: It appears that you are trying to use the old API, which has been deprecated. Please update your code to the new API or install the old version of gganimate from https://github.com/thomasp85/gganimate/releases/tag/v0.1.1
My Code (with different object names from website):
library(tidyverse)
library(maptools)
library(cartogram)
library(viridis)
library(sf)
library(mapproj)
library(gganimate)
library(tweenr)
data("wrld_simpl")
cartogram_data = wrld_simpl[wrld_simpl$REGION==2,]
cartogram_data_sf <- st_as_sf(cartogram_data)
cartogram_sf_proj = st_transform(cartogram_data_sf,3857)
cartogram_plot <- cartogram::cartogram(cartogram_sf_proj, "POP2005", itermax =7)
cartogram_data_df <- broom::tidy(cartogram_data) %>%
dplyr::left_join(cartogram_data#data, by=c("id"="ISO3"))
cartogram_df <- broom::tidy(cartogram_data) %>%
dplyr::left_join(cartogram_data#data, by=c("id"="ISO3"))
Here it uses tweenr which I have never seen before:
cartogram_data_df$id <- seq(1,nrow(cartogram_data_df))
cartogram_df$id <- seq(1,nrow(cartogram_df))
data <- rbind(cartogram_df, cartogram_data_df, cartogram_df)
# Set transformation type + time
data$ease <- "cubic-in-out"
data$time <- rep(c(1:3), each=nrow(cartogram_df))
# Calculate the transition between these 2 objects?
dt <- tween_elements(data, time='time', group='id', ease='ease', nframes = 30)
# check a few frame
ggplot() +
geom_polygon(data = dt %>% filter(.frame==0) %>% arrange(order),
aes(fill = POP2005, x = long, y = lat, group = group), size=0, alpha=0.9
)
ggplot() +
geom_polygon(data = dt %>% filter(.frame==5) %>% arrange(order),
aes(fill = POP2005, x = long, y = lat, group = group) , size=0, alpha=0.9
)
ggplot() +
geom_polygon(data = dt %>% filter(.frame==10) %>% arrange(order),
aes(fill = POP2005, x = long, y = lat, group = group) , size=0, alpha=0.9
)
Animation Code: (this step/code chunk gives an error)
africa_plt <- ggplot() +
geom_polygon(data = dt %>% arrange(order) , aes(fill = POP2005/1000000, x = long, y = lat, group = group, frame=.frame) , size=0, alpha=0.9) +
theme_void() +
scale_fill_viridis(
name="Population (M)", breaks=c(1,50,100, 140),
guide = guide_legend(
keyheight = unit(3, units = "mm"), keywidth=unit(12, units = "mm"),
label.position = "bottom", title.position = 'top', nrow=1)
) +
labs( title = "Africa", subtitle="Population per country in 2005" ) +
ylim(-35,35) +
theme(
text = element_text(color = "#22211d"),
plot.background = element_rect(fill = "#f5f5f4", color = NA),
panel.background = element_rect(fill = "#f5f5f4", color = NA),
legend.background = element_rect(fill = "#f5f5f4", color = NA),
plot.title = element_text(size= 22, hjust=0.5, color = "#4e4d47", margin = margin(b = -0.1, t = 0.4, l = 2, unit = "cm")),
plot.subtitle = element_text(size= 13, hjust=0.5, color = "#4e4d47", margin = margin(b = -0.1, t = 0.4, l = 2, unit = "cm")),
legend.position = c(0.2, 0.26)
) +
coord_map() +
# transition_manual(F)
# Make the animation
#animation::ani.options(interval = 1/9)
gganimate(africa_plt, "Animated_Africa.gif", title_frame = F)
I have tried using transition_manual(F) instead of gganimate(africa_plt, "Animated_Africa.gif", title_frame = F) but that didn't work either.
I have a graph made with ggplot2, I chose a color for the fill and another for the border, but the border color is overlapping the fill color, even if I decrease its size. Generating the graph on macOS doesn't return any errors, only on Windows.
I'm using the same version of R and ggplot2 in the two systems.
Graph on Windows 10:
Graph on macOS Catalina:
Code used in both systems:
library(tidyverse)
library(zoo)
library(httr)
library(openxlsx)
url <- httr::GET("https://xx9p7hp1p7.execute-api.us-east-1.amazonaws.com/prod/PortalGeral",
httr::add_headers("X-Parse-Application-Id" =
"unAFkcaNDeXajurGB7LChj8SgQYS2ptm")) %>%
httr::content() %>%
'[['("results") %>%
'[['(1) %>%
'[['("arquivo") %>%
'[['("url")
dados <- openxlsx::read.xlsx(url) %>%
filter(is.na(municipio), is.na(codmun))
for(i in 9:16) {
dados[,i] <- as.numeric(dados[,i])
}
dados[,8] <- convertToDate(dados[,8])
dados_mm7d <- dados %>%
mutate(mm7dCasos = rollmean(casosNovos, 7, fill = list(NA, NULL, NA), align = "right"),
mm7dCasos = ifelse(is.na(mm7dCasos), 0, mm7dCasos),
mm7dCasos = ifelse(is.infinite(mm7dCasos), 0, mm7dCasos)) %>%
filter(data > "2020-03-30", !is.na(estado))
dados %>%
filter(data > "2020-03-23", !is.na(estado)) %>%
ggplot() +
geom_col(aes(x = data, y = casosNovos), na.rm = TRUE, color = "black", fill = "#0181ae", size = 0.1, width = 0.6) +
geom_line(data = dados_mm7d, aes(x = data, y = mm7dCasos), color = "#dd0533", size = 0.7) +
scale_y_continuous(trans = 'log2', labels = scales::comma) +
labs(x = "", y = "") +
coord_cartesian(ylim = c(2, 8192)) +
scale_x_date(date_labels = "%b %d", date_breaks = "2 week") +
theme(text = element_text(size = 10), axis.text.x = element_text(angle = 90, hjust = 1)) +
theme(panel.background = element_rect(fill = "white", colour = "grey10", linetype = "solid")) +
facet_wrap(~estado, nrow = 3)
You can plot your graph using Cairo to get anti-aliased graphs on Windows:
install.packages("Cairo")
library(Cairo)
Cairo("graph.png", units="in", width=8, height=7, dpi=200)
here goes your plot code
dev.off()
This is my first question to StackExchange, and I've searched for answers that have been helpful, but haven't really gotten me to where I'd like to be.
This is a stacked bar chart, combined with a point chart, combined with a line.
Here's my code:
theme_set(theme_light())
library(lubridate)
FM <- as.Date('2018-02-01')
x.range <- c(FM - months(1) - days(1) - days(day(FM) - 1), FM - days(day(FM) - 1) + months(1))
x.ticks <- seq(x.range[1] + days(1), x.range[2], by = 2)
#populate example data
preds <- data.frame(FM = FM, DATE = seq(x.range[1] + days(1), x.range[2] - days(1), by = 1))
preds <- data.frame(preds, S_O = round(seq(1, 1000000, by = 1000000/nrow(preds))))
preds <- data.frame(preds, S = round(ifelse(month(preds$FM) == month(preds$DATE), day(preds$DATE) / 30.4, 0) * preds$S_O))
preds <- data.frame(preds, O = preds$S_O - preds$S)
preds <- data.frame(preds, pred_sales = round(1000000 + rnorm(nrow(preds), 0, 10000)))
preds$ma <- with(preds, stats::filter(pred_sales, rep(1/5, 5), sides = 1))
y.max <- ceiling(max(preds$pred_sales) / 5000) * 5000 + 15000
line.cols <- c(O = 'palegreen4', S = 'steelblue4',
P = 'maroon', MA = 'blue')
fill.cols <- c(O = 'palegreen3', S = 'steelblue3',
P = 'red')
p <- ggplot(data = preds,
mapping = aes(DATE, pred_sales))
p <- p +
geom_bar(data = reshape2::melt(preds[,c('DATE', 'S', 'O')], id.var = 'DATE'),
mapping = aes(DATE, value, group = 1, fill = variable, color = variable),
width = 1,
stat = 'identity',
alpha = 0.5) +
geom_point(mapping = aes(DATE, pred_sales, group = 2, fill = 'P', color = 'P'),
shape = 22, #square
alpha = 0.5,
size = 2.5) +
geom_line(data = preds[!is.na(preds$ma),],
mapping = aes(DATE, ma, group = 3, color = 'MA'),
alpha = 0.8,
size = 1) +
geom_text(mapping = aes(DATE, pred_sales, label = formatC(pred_sales / 1000, format = 'd', big.mark = ',')),
angle = 90,
size = 2.75,
hjust = 1.25,
vjust = 0.4) +
labs(title = sprintf('%s Sales Predictions - %s', 'Overall', format(FM, '%b %Y')),
x = 'Date',
y = 'Volume in MMlbs') +
theme(axis.text.x = element_text(angle = 45, vjust = 1, hjust = 1, size = 8),
panel.grid.major.x = element_blank(),
panel.grid.minor.x = element_blank(),
legend.title = element_blank(),
legend.position = 'bottom',
legend.text = element_text(size = 8),
legend.margin = margin(t = 0.25, unit = 'cm')) +
scale_x_date(breaks = x.ticks,
date_labels = '%b %e',
limits = x.range) +
scale_y_continuous(limits = c(0, y.max),
labels = function(x) { formatC(x / 1000, format='d', big.mark=',') }) +
scale_color_manual(values = line.cols,
breaks = c('MA'),
labels = c(MA = 'Mvg Avg (5)')) +
scale_fill_manual(values = fill.cols,
breaks = c('P', 'O', 'S'),
labels = c(O = 'Open Orders', S = 'Sales', P = 'Predictions'))
p
The chart it generates is this:
As you can see, the legend does a couple of funky things. It's close, but not quite there. I only want boxes with exterior borders for Predictions, Open Orders, and Sales, and only a blue line for the Mvg Avg (5).
Any advice would be appreciated.
Thanks!
Rather late, but if you are still interested to understand this problem, the following should work. Explanations are included as comments within the code:
library(dplyr)
preds %>%
# scale the values for ALL numeric columns in the dataset, before
# passing the dataset to ggplot()
mutate_if(is.numeric, ~./1000) %>%
# since x / y mappings are stated in the top level ggplot(), there's
# no need to repeat them in the subsequent layers UNLESS you want to
# override them
ggplot(mapping = aes(x = DATE, y = pred_sales)) +
# 1. use data = . to inherit the top level data frame, & modify it on
# the fly for this layer; this is neater as you are essentially
# using a single data source for the ggplot object.
# 2. geom_col() is a more succinct way to say geom_bar(stat = "identity")
# (I'm using tidyr rather than reshape package, since ggplot2 is a
# part of the tidyverse packages, & the two play together nicely)
geom_col(data = . %>%
select(S, O, DATE) %>%
tidyr::gather(variable, value, -DATE),
aes(y = value, fill = variable, color = variable),
width = 1, alpha = 0.5) +
# don't show legend for this layer (o/w the fill / color legend would
# include a square shape in the centre of each legend key)
geom_point(aes(fill = 'P', color = 'P'),
shape = 22, alpha = 0.5, size = 2.5, show.legend = FALSE) +
# use data = . %>% ... as above.
# since the fill / color aesthetic mappings from the geom_col layer would
# result in a border around all fill / color legends, avoid it all together
# here by hard coding the line color to "blue", & map its linetype instead
# to create a separate linetype-based legend later.
geom_line(data = . %>% na.omit(),
aes(y = ma, linetype = 'MA'),
color = "blue", alpha = 0.8, size = 1) +
# scales::comma is a more succinct alternative to formatC for this use case
geom_text(aes(label = scales::comma(pred_sales)),
angle = 90, size = 2.75, hjust = 1.25, vjust = 0.4) +
labs(title = sprintf('%s Sales Predictions - %s', 'Overall', format(FM, '%b %Y')),
x = 'Date',
y = 'Volume in MMlbs') +
theme(axis.text.x = element_text(angle = 45, vjust = 1, hjust = 1, size = 8),
panel.grid.major.x = element_blank(),
panel.grid.minor.x = element_blank(),
legend.title = element_blank(),
legend.position = 'bottom',
legend.text = element_text(size = 8),
legend.margin = margin(t = 0.25, unit = 'cm')) +
scale_x_date(breaks = x.ticks,
date_labels = '%b %e',
limits = x.range) +
# as above, scales::comma is more succinct
scale_y_continuous(limits = c(0, y.max / 1000),
labels = scales::comma) +
# specify the same breaks & labels for the manual fill / color scales, so that
# a single legend is created for both
scale_color_manual(values = line.cols,
breaks = c('P', 'O', 'S'),
labels = c(O = 'Open Orders', S = 'Sales', P = 'Predictions')) +
scale_fill_manual(values = fill.cols,
breaks = c('P', 'O', 'S'),
labels = c(O = 'Open Orders', S = 'Sales', P = 'Predictions')) +
# create a separate line-only legend using the linetype mapping, with
# value = 1 (i.e. unbroken line) & specified alpha / color to match the
# geom_line layer
scale_linetype_manual(values = 1,
label = 'Mvg Avg (5)',
guide = guide_legend(override.aes = list(alpha = 1,
color = "blue")))
I wrote the following code to produce graphs like the one at the end. The thing is that I need to modify the dates shown in the x axis to make the image more understandable (ideally showing a point every two quarters)
Here is the dataset
And here is the code, which works fin until I try to modify scale_x_date. I tried to change in several ways the way in which the dates are introduced in the plot without success. I'd appreciate any help.
#rm(list=ls())
library(urca)
library(ggplot2)
library(ggrepel)
library(reshape2)
library(pracma)
library(extrafont)
library(dplyr)
library(lubridate)
library(zoo)
loadfonts(device = "win")
### Data set
info <- read.csv("base_completa_frame.csv",header=TRUE,dec=",", sep = ";")
info <- ts(info,frequency =4, c(1982,1))
info <- window(info, start=c(2000,4))
### Transf.
data_var <- diff(info,4)/ts(head(info,dim(info)[1]-4), start = c(2001,4), frequency = 4)
data_var <- ts(data_var,frequency =4, c(2001,4))
data_var <- window(data_var, start = c(2002,4))
data_var[,c(25:27)] <- window(info[,c(25:27)], start = c(2002,4))
data_var[,c(7,8,13,14)] <- window(diff(info[,c(7,8,13,14)]), start = c(2002,4))
data_var[,c(25:27,48:50)] <- window(diff(info[,c(25:27,48:50)],4), start = c(2002,4))
colnames(data_var) <- colnames(info)
data_var <- data_var[,-11:-12]
### Graphs
# Growth
time_ref <- time(data_var)
time_rec <- format(date_decimal(as.numeric(time_ref)),"%Y-%m-%d")
time_rec <- seq(as.Date(time_rec[1]), length = length(time_rec)[1], by = "quarter")
time_rec <- na.omit(time_rec[2*(1:length(time_rec))])
label_rec <- as.yearqtr(time_rec)
data_plot <- data.frame(data_var)
data_plot[,"time_ref"] <- time_ref
data_melt <- melt(data_plot, id = "time_ref")
for (i in nomb_melt){
ts_ref <- data_melt[which(data_melt$variable == i),]
ts_ref[,"value"] <- 100*ts_ref[,"value"]
sd_ref <- sd(ts_ref[,"value"])
t_ref <- qt(0.975,dim(ts_ref)[1]-5)*sd_ref/sqrt(dim(ts_ref)[1]-4)
test_L <- tail(ts_ref[,"value"],dim(ts_ref)[1]-4) < head(ts_ref[,"value"],dim(ts_ref)[1]-4) - t_ref
test_L <- which(test_L == TRUE)
test_U <- tail(ts_ref[,"value"],dim(ts_ref)[1]-4) > head(ts_ref[,"value"],dim(ts_ref)[1]-4) + t_ref
test_U <- which(test_U == TRUE)
ts_ref <- tail(ts_ref,dim(ts_ref)[1]-4)
ind_test <- 1:dim(ts_ref)[1]
ind_test[test_L] <- "Menor"
ind_test[test_U] <- "Mayor"
ind_test[-c(test_L,test_U)] <- "Igual"
ts_ref[,"ind_test"] <- ind_test
peaks <- findpeaks(ts_ref[,"value"], sortstr=TRUE)[1:4,2]
mins <- findpeaks(-ts_ref[,"value"], sortstr=TRUE)[1:4,2]
p <- ggplot(ts_ref, aes(x = time_ref, y = value, color = variable)) +
geom_rect(aes(xmin = time_ref,xmax = dplyr::lead(time_ref),
ymin = -Inf, ymax = Inf, fill = factor(ind_test)),
alpha = .2, linetype=0) +
scale_fill_manual(values = alpha(c("yellow","green", "red"), .2)) +
geom_line() + scale_color_manual(values="black") +
labs(x =" ", y = "Porcentaje") +
theme_bw() +
theme(plot.title = element_text(hjust = 0.5),
legend.position="none",
panel.border = element_blank(),
axis.line = element_line(colour = "black"),
strip.text = element_text(size=14),
text=element_text(family="Calibri"),
axis.text.x = element_text(angle=0)) +
geom_label_repel(
data = ts_ref[peaks,],
aes(label = format(round(ts_ref[peaks,"value"],2), 2)),
size = 3,
nudge_y = 1,
arrow = arrow(length = unit(0.01, 'npc')),
point.padding = unit(0.02, 'npc'),
label.size = NA, fill = "white") +
geom_label_repel(
data = ts_ref[mins,],
aes(label = format(round(ts_ref[mins,"value"],2), 2)),
size = 3,
nudge_y = -1,
arrow = arrow(length = unit(0.01, 'npc')),
point.padding = unit(0.02, 'npc'),
label.size = NA, fill = "white") +
scale_x_date(breaks = as.Date(time_rec),
labels = label_rec)
print(p)
}
Finally, here is one of the almost ready plots
I also didn't find a way to solve using scale_x_date. However, since you're using as.yearqtr to create the labels, I tried scale_x_yearqtr and it worked. For simplicity, I'm going to plot for PIB_Colombia and will only include here the code for the plot:
ggplot(ts_ref, aes(x = time_ref, y = value, color = variable)) +
geom_rect(aes(xmin = time_ref,xmax = dplyr::lead(time_ref),
ymin = -Inf, ymax = Inf, fill = factor(ind_test)),
alpha = .2, linetype=0) +
scale_fill_manual(values = alpha(c("yellow","green", "red"), .2)) +
geom_line() + scale_color_manual(values="black") +
labs(x =" ", y = "Porcentaje") +
theme_bw() +
theme(plot.title = element_text(hjust = 0.5),
legend.position="none",
panel.border = element_blank(),
axis.line = element_line(colour = "black"),
strip.text = element_text(size=14),
#text=element_text(family="Calibri"),
axis.text.x = element_text(angle=0)) +
geom_label_repel(
data = ts_ref[peaks,],
aes(label = format(round(ts_ref[peaks,"value"],2), 2)),
size = 3,
nudge_y = 1,
arrow = arrow(length = unit(0.01, 'npc')),
point.padding = unit(0.02, 'npc'),
label.size = NA, fill = "white") +
geom_label_repel(
data = ts_ref[mins,],
aes(label = format(round(ts_ref[mins,"value"],2), 2)),
size = 3,
nudge_y = -1,
arrow = arrow(length = unit(0.01, 'npc')),
point.padding = unit(0.02, 'npc'),
label.size = NA, fill = "white") +
scale_x_yearqtr(format = "%Y Q%q", n=length(time_rec))
This yielded the plot:
I used exactly the number of breaks you wanted to include, but you can control that by changing n within scale_x_yearqtr.
I'm trying to add an interactive heatmap to my Shiny app, but I also have interactive graphs using ggiraph. I'm currently using the d3heatmap package, but the heatmaps don't render in the app. I've created a toy example to illustrate this:
library(shiny)
library(ggiraph)
library(d3heatmap)
ui <- fluidPage(
d3heatmapOutput('d3'),
ggiraphOutput('gg')
)
server <- function(input, output, session) {
# Create heatmap
output$d3 <- renderD3heatmap({
d3heatmap(matrix(1:100, nrow = 100, ncol = 100))
})
# Create ggiraph
output$gg <- renderggiraph({
p <- ggplot(iris, aes(x = Sepal.Length, y = Petal.Width,
color = Species, tooltip = iris$Species) ) +
geom_point_interactive()
ggiraph(code = {print(p)})
})
}
shinyApp(ui = ui, server = server)
Together, only the ggiraph renders, but the heatmap does not. However, if you comment out the ggiraph code, the heatmap renders. I tried switching the order of loading the packages, but that still didn't work.
I'm currently running on R 3.2.2 (I have to use this version because the company servers only run on this version, and neither my manager nor I have the authority to update it). I tried downloading the shinyheatmap, heatmaply, and heatmap.2 packages, but because of versioning issues, the installations were unsuccessful.
So right now, I've just used pheatmap to create the heatmaps, but they aren't interactive (i.e., I can't get values when I hover over individual cells, and I can't zoom in). Is there any workaround for this, or are there other interactive heatmap packages out there that would work? I'd like to avoid changing all of my ggiraph graphs to plotly graphs since there are a lot of them in my code.
Please let me know if there's any other information you need. Any suggestions would be much appreciated!
(just to let you know I am the author of ggiraph)
There is a conflict between ggiraph and d3heatmap because ggiraph is using d3.js version 4 and d3heatmap is using D3.js version 3. I don't think there is a solution to solve that conflict.
However, building an interactive heatmap with ggplot2/ggiraph is not that difficult. See below:
library(dplyr)
library(tidyr)
library(ggplot2)
library(ggiraph)
library(ggdendro)
# mydata <- cor(mtcars)
mydata <- matrix(runif(2500, min = -2, max = 2), ncol = 50)
row.names(mydata) <- paste0("row_", seq_len(nrow(mydata)))
colnames(mydata) <- paste0("col_", seq_len(ncol(mydata)))
# dendrogram for rows
hc <- hclust(dist(mydata), "ave")
dhr <- as.dendrogram(hc)
order_r <- rownames(mydata)[hc$order]
# dendrogram for columns
hc <- hclust(dist(t(mydata)), "ave")
dhc <- as.dendrogram(hc)
order_c <- colnames(mydata)[hc$order]
# the data
expr_set <- bind_cols(
data_frame(rowvar = rownames(mydata)),
as.data.frame(mydata)
)
expr_set <- gather(expr_set, colvar, measure, -rowvar)
expr_set$rowvar <- factor( expr_set$rowvar, levels = order_r )
expr_set$colvar <- factor( expr_set$colvar, levels = order_c )
expr_set <- arrange(expr_set, rowvar, colvar)
# get data for dendrograms - IMHO, ggdendro is the hero here...
data_c <- dendro_data(dhc, type = "rectangle")
data_c <- segment(data_c) %>% mutate(
y = y + length(order_r) + .5,
yend = yend + length(order_r) + .5
)
data_r <- dendro_data(dhr, type = "rectangle")
data_r <- segment(data_r)
data_r <- data_r %>%
mutate( x_ = y + length(order_c) + .5,
xend_ = yend + length(order_c) + .5,
y_ = x,
yend_ = xend )
expr_set <- expr_set %>%
mutate(
tooltip = sprintf("Row: %s<br/>Col: %s<br/>measure: %.02f",
rowvar, colvar, measure) ,
data_id = sprintf("%s_%s", rowvar, colvar)
)
# all data are tidy and can be now used with ggplot
p <- ggplot(data = expr_set, aes(x = colvar, y = rowvar) ) +
geom_tile_interactive(aes(fill = measure, tooltip = tooltip, data_id = data_id), colour = "white") +
scale_fill_gradient(low = "white", high = "#BC120A") +
geom_segment(
data = data_c,
mapping = aes(x = x, y = yend, xend = xend, yend = y),
colour = "gray20", size = .2) +
geom_segment(
data = data_r,
mapping = aes(x = x_, y = y_, xend = xend_, yend = yend_),
colour = "gray20", size = .2) +
coord_equal()
# cosmetics
p <- p + theme_minimal() +
theme(
legend.position = "right",
panel.grid.minor = element_line(color = "transparent"),
panel.grid.major = element_line(color = "transparent"),
axis.ticks.length = unit(2, units = "mm"),
plot.title = element_text(face = "bold", hjust = 0.5, size = 12),
axis.title = element_text(size = 9, colour = "gray30"),
axis.text.y = element_text(hjust = 1, size = 5, colour = "gray40"),
axis.text.x = element_text(angle = 90, hjust = 1, size = 5, colour = "gray40"),
legend.title=element_text(face = "bold", hjust = 0.5, size=8),
legend.text=element_text(size=6)
)
ggiraph(ggobj = p)
Hope it helps
I know that this question is answered some time ago but I've ran into the same problem and i was not able to use ggplot2 because it was just to slow to work with my Shiny application. The heatmaply package is allot faster and easier to implement. I performed a mini-benchmark (n= 20).
with ggplot2 took an average time of 64 seconds. With heatmaply it took only 2 seconds. both methods use the 'ave' method of hclust.I hope this is helpfull.
mini-benchmark n= 20 of ggplot vs heatmaply
here is the code i used:
library(tidyr)
library(ggplot2)
library(ggiraph)
library(ggdendro)
library(heatmaply)
# mydata <- cor(mtcars)
create_data <- function(){
df <- matrix(runif(2500, min = -2, max = 2), ncol = 50)
row.names(df) <- paste0("row_", seq_len(nrow(df)))
colnames(df) <- paste0("col_", seq_len(ncol(df)))
return(df)
}
gg2heat <- function(mydata){
# dendrogram for rows
hc <- hclust(dist(mydata), "ave")
dhr <- as.dendrogram(hc)
order_r <- rownames(mydata)[hc$order]
# dendrogram for columns
hc <- hclust(dist(t(mydata)), "ave")
dhc <- as.dendrogram(hc)
order_c <- colnames(mydata)[hc$order]
# the data
expr_set <- bind_cols(
data_frame(rowvar = rownames(mydata)),
as.data.frame(mydata)
)
expr_set <- gather(expr_set, colvar, measure, -rowvar)
expr_set$rowvar <- factor( expr_set$rowvar, levels = order_r )
expr_set$colvar <- factor( expr_set$colvar, levels = order_c )
expr_set <- arrange(expr_set, rowvar, colvar)
# get data for dendrograms - IMHO, ggdendro is the hero here...
data_c <- dendro_data(dhc, type = "rectangle")
data_c <- segment(data_c) %>% mutate(
y = y + length(order_r) + .5,
yend = yend + length(order_r) + .5
)
data_r <- dendro_data(dhr, type = "rectangle")
data_r <- segment(data_r)
data_r <- data_r %>%
mutate( x_ = y + length(order_c) + .5,
xend_ = yend + length(order_c) + .5,
y_ = x,
yend_ = xend )
expr_set <- expr_set %>%
mutate(
tooltip = sprintf("Row: %s<br/>Col: %s<br/>measure: %.02f",
rowvar, colvar, measure) ,
data_id = sprintf("%s_%s", rowvar, colvar)
)
# all data are tidy and can be now used with ggplot
p <- ggplot(data = expr_set, aes(x = colvar, y = rowvar) ) +
geom_tile_interactive(aes(fill = measure, tooltip = tooltip, data_id = data_id), colour = "white") +
scale_fill_gradient(low = "white", high = "#BC120A") +
geom_segment(
data = data_c,
mapping = aes(x = x, y = yend, xend = xend, yend = y),
colour = "gray20", size = .2) +
geom_segment(
data = data_r,
mapping = aes(x = x_, y = y_, xend = xend_, yend = yend_),
colour = "gray20", size = .2) +
coord_equal()
# cosmetics
p <- p + theme_minimal() +
theme(
legend.position = "right",
panel.grid.minor = element_line(color = "transparent"),
panel.grid.major = element_line(color = "transparent"),
axis.ticks.length = unit(2, units = "mm"),
plot.title = element_text(face = "bold", hjust = 0.5, size = 12),
axis.title = element_text(size = 9, colour = "gray30"),
axis.text.y = element_text(hjust = 1, size = 5, colour = "gray40"),
axis.text.x = element_text(angle = 90, hjust = 1, size = 5, colour = "gray40"),
legend.title=element_text(face = "bold", hjust = 0.5, size=8),
legend.text=element_text(size=6)
)
ggiraph(ggobj = p)
}
htmp_gg <- c()
htmp_maply <-c()
for (i in 1:20){
df <- create_data()
time_gg <- (system.time(gg2heat(df)))[3]
htmp_gg<- append(htmp_gg, values = time_gg)
time_heatmaply <- (system.time(heatmaply::heatmaply(df, hclust_method = 'ave')))[3]
htmp_maply<- append(htmp_maply, values = time_heatmaply)
rm(df)
}
score <- data.frame(htmp_gg, htmp_maply)%>% gather(key = 'method', value = 'time')
p <- ggplot(score, aes(x = method, y = time, fill = method))+geom_violin()+ stat_summary(fun.y=median, geom="point", size=2, color="black")
print(p)