Related
While looking at upskilling myself, I was watching the really quite excellent ggplot2 workshop to get myself better at using the package by understanding how it works at a fundamental level.
As part of that workshop, I was struck by one of the visualisations used in the workshop as being especially useful for explaining a layered hierarchy of dependencies, and I'm looking to figure out how I could generate such a picture (ideally using R).
These two pictures show the two parts of the visualisation I'm trying to reproduce:
Stacked Planes with labels:
Stacked Planes, with transparencies for most, and labels (appropriately highlighted):
I have been able to produce something similar, using rgl, but it's not nearly as nice. Given I am trying to upskill myself in ggplot2, I would like to be able to produce it using ggplot2 (or one of it's extensions), as that would enable me to control some of the "nicities" of the graphic much easier).
Is this possible using ggplot2 or an extension package?
The code for producing it in rgl is:
library(rgl)
# Create some dummy data
dat <- replicate(2, 1:3)
# Initialize the scene, no data plotted
# hardcoded user matrix of a particular view (so I can go straight to that view each time)
userMatrix_orig <- matrix(c(-0.7069399, -0.2729415, 0.6524867, 0.0000000, 0.7072651, -0.2773000, 0.6502926, 0.0000000, 0.003442926, 0.921199083, 0.389076293, 0.000000000, 0, 0, 0, 1), nrow = 4 )
plot3d(dat, type = 'n', xlim = c(-1, 1), ylim = c(-1, 1), zlim = c(-10, 10),
xlab = '', ylab = '', zlab = '', axes=FALSE)
view3d(userMatrix=userMatrix_orig)
material3d(alpha=1.0)
# Add planes
planes3d(1, 1, 1, -2, col = 'paleturquoise', alpha = 0.8, name="hello")
planes3d(1, 1, 1, -4, col = 'palegreen', alpha = 0.8)
planes3d(1, 1, 1, -6, col = 'palevioletred', alpha = 0.8)
planes3d(1, 1, 1, -8, col = 'midnightblue', alpha = 0.8)
planes3d(1, 1, 1, 0, col = 'red', alpha = 0.8)
planes3d(1, 1, 1, 2, col = 'green', alpha = 0.8)
planes3d(1, 1, 1, 4, col = 'orange', alpha = 0.8)
planes3d(1, 1, 1, 6, col = 'blue', alpha = 0.8)
# Label the planes
family_val <- c("sans")
adj_val <- 1
cex_val <- 2.5
text3d(x=1, y =-1, z = -6, texts="data", adj = adj_val, family = family_val, cex = cex_val )
text3d(x=1, y =-1, z = -4, texts="mapping", adj = adj_val, family = family_val, cex = cex_val )
text3d(x=1, y =-1, z = -2, texts="statistics", adj = adj_val, family = family_val, cex = cex_val )
text3d(x=1, y =-1, z = 0, texts="scales", adj = adj_val, family = family_val, cex = cex_val )
text3d(x=1, y =-1, z = 2, texts="geometries", adj = adj_val, family = family_val, cex = cex_val )
text3d(x=1, y =-1, z = 4, texts="facets", adj = adj_val, family = family_val, cex = cex_val )
text3d(x=1, y =-1, z = 6, texts="coordinates", adj = adj_val, family = family_val, cex = cex_val )
text3d(x=1, y =-1, z = 8, texts="theme", adj = adj_val, family = family_val, cex = cex_val )
and the graphic I produced using that is:
I would recreate the image in ggplot with a function like this:
make_graphic <- function(highlight = 1:8) {
library(ggplot2)
alpha_vals <- c(0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2)
alpha_vals[highlight] <- 1
df <- data.frame(x = rep(c(0.5, 0.75, 1, 0.75, 0.5), 8),
y = rep(c(0.5, 0, 0.5, 1, 0.5), 8) + rep(0:7, each = 5)/2,
z = rep(LETTERS[1:8], each = 5))
ggplot(df, aes(x, y)) +
geom_polygon(aes(fill = z, alpha = z)) +
geom_text(data = data.frame(x = 0.48, y = rev(0.5 + (0:7)/2),
z = rev(LETTERS[1:8]),
a = c("THEME", "COORDINATES", "FACETS",
"GEOMETRIES", "SCALES", "STATISTICS",
"MAPPING", "DATA")), fontface = 2,
family = "opencondensed",
aes(label = a, alpha = z), colour = "white", size = 10, hjust = 1) +
scale_x_continuous(limits = c(0.2, 1)) +
scale_fill_manual(values = c("#a6aaa9", "#ef4e47", "#34a5da", "#ff9d35",
"#8abe5e", "#ffe989", "#c52060", "#3f969a")) +
scale_alpha_manual(values = alpha_vals) +
theme_void() +
theme(legend.position = "none",
plot.background = element_rect(fill = "#222222"))
}
This allows the graphic to be recreated easily by doing:
make_graphic()
And if you want to just highlight the second bottom item, you can do:
make_graphic(2)
Here's an attempt.
Data
library(dplyr)
mydata <- data.frame(
label = c("THEME", "COORDINATES", "FACETS", "GEOMETRIES", "SCALES", "STATISTICS", "MAPPING", "DATA"),
ybase = 8:1,
color = c("#3f969a", "#c52060", "#ffe989", "#8abe5e", "#ff9d35", "#34a5da", "#ef4e47", "#a6aaa9")
) %>%
rowwise() %>%
mutate(
xs = list(c(0, 2, 0, -2)),
ys = lapply(ybase, `+`, c(1.1, 0, -1.1, 0)),
ord = list(1:4)
) %>%
ungroup() %>%
tidyr::unnest(c(xs, ys, ord)) %>%
arrange(ybase, ord)
spldata <- split(mydata, mydata$label)
spldata <- spldata[order(sapply(spldata, function(z) z$ybase[1]))]
The reason I create spldata is because ggplot2 does not (afaik) allow setting the z-order easily, so I will resort (next block) to plotting the polygons iteratively.
Plot, no highlights
library(ggplot2)
ggplot(mydata, aes(xs, ys, group = label)) +
lapply(spldata, function(dat) {
geom_polygon(aes(fill = I(color)), data = dat)
}) +
geom_text(aes(x = -2.2, y = ybase, label = label),
hjust = 1, color = "white", size = 7,
data = ~ filter(., ord == 1)) +
guides(fill = "none", color = "none", alpha = "none") +
scale_x_continuous(expand = expansion(add = c(2.5, 0.2))) +
theme(
plot.background = element_rect(colour = "black", fill = "black"),
panel.background = element_rect(colour = "black", fill = "black"),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text = element_blank(), axis.ticks = element_blank()
)
Plot, with highlight
The changes here:
add alpha = if ... to geom_polygons
split the geom_text into two calls, since I did not want to found colour= aesthetics between polygons and texts
this <- c("THEME", "MAPPING")
ggplot(mydata, aes(xs, ys, group = label)) +
lapply(spldata, function(dat) {
geom_polygon(aes(fill = I(color)),
alpha = if (dat$label[1] %in% this) 1 else 0.2,
data = dat)
}) +
{
if (any(!mydata$label %in% this))
geom_text(aes(x = -2.2, y = ybase, label = label),
hjust = 1, color = "gray50", size = 7,
data = ~ filter(., ord == 1, !label %in% this))
} +
{
if (any(this %in% mydata$label))
geom_text(aes(x = -2.2, y = ybase, label = label),
hjust = 1, color = "white", size = 7,
data = ~ filter(., ord == 1, label %in% this))
} +
guides(fill = "none", color = "none", alpha = "none") +
scale_x_continuous(expand = expansion(add = c(2.5, 0.2))) +
theme(
plot.background = element_rect(colour = "#222222", fill = "#222222"),
panel.background = element_rect(colour = "#222222", fill = "#222222"),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.text = element_blank(), axis.ticks = element_blank()
)
(I borrowed From AllanCameron the idea of "one or more" for this in order to be able to highlight more than one (or perhaps none).
After working on it a while myself, I came up with the following function:
library(ggplot2)
generate_layer_diagram <- function(highlight_layers = "all", num_layers = 8,
overwrite_layer_labels = c('DATA','MAPPING','SCALES','STATISTICS','GEOMETRIES','FACETS','COORDINATES','THEMES'),
overwrite_colours = c('grey','blue','red','orange','paleturquoise','palegreen','palevioletred','midnightblue'),
base_colour_set_name="Set3",
base_num_colours=12L,
save_path="",
transparent_background=FALSE) {
base_image_height <- 20.32
base_image_width <- 21.77
scaling_factor <- 0.69
alpha_highlight <- 1.0
alpha_mute <- 0.2
font_size <- 8*scaling_factor
font_weight <- "bold"
if(transparent_background) {
font_colour <- "black"
background_color <- "transparent"
} else {
font_colour <- "white"
background_color <- "black"
}
diamond <- function(side_length, centre) {
base <- matrix(c(1, 0, 0, 1, -1, 0, 0, -1), nrow = 2) * sqrt(2) / 2
trans <- (base * side_length) + centre
as.data.frame(t(trans))
}
if(is.character(highlight_layers) && highlight_layers == "all") {
highlight_layers = c(1:num_layers)
}
highlights <- c(rep(FALSE,num_layers))
highlights[highlight_layers] <- TRUE
layer_labels <- paste0(c("layer_"),c(1:num_layers)) %>% data.table
layer_labels[,labels:=.][,.:=NULL]
if(length(overwrite_layer_labels) > num_layers) {
overwrite_layer_labels <- overwrite_layer_labels[1:num_layers]
}
layer_labels[1:length(overwrite_layer_labels),labels:=overwrite_layer_labels]
base_colour_set <- RColorBrewer::brewer.pal(base_num_colours,base_colour_set_name) %>% data.table()
base_colour_set <- base_colour_set[,colours:=.][,.:=NULL]
if(num_layers > base_num_colours) {
base_colour_set <- base_colour_set[rep(seq_len(nrow(base_colour_set)), ceiling(num_layers/base_num_colours)), ]
}
base_colour_set <- base_colour_set[1:num_layers]
colour_set <- base_colour_set
if(length(overwrite_colours) > num_layers) {
overwrite_colours <- overwrite_colours[1:num_layers]
}
colour_set[1:length(overwrite_colours),colours:=overwrite_colours]
dt <- data.table(side_lengths = rep(c(2),num_layers),
centres = matrix(c(1 + rep(0,num_layers),2 + 0:(num_layers-1)),nrow=num_layers),
colours = colour_set,
labels = layer_labels,
highlights = highlights)
dt[,alphas:=(as.numeric(highlights)*alpha_highlight + as.numeric(!highlights)*alpha_mute)]
myplot <- ggplot() + lapply(c(1:num_layers),function(x) {geom_polygon(data = diamond(dt$side_lengths[x], c(dt$centres.V1[x],dt$centres.V2[x])), mapping = aes(x = V1, y = V2), fill = dt$colours[x], alpha = dt$alphas[x])}) +
lapply(c(1:num_layers),function(z) {annotate("text", x = -(dt$centres.V1[z]/2)*1.1, y = dt$centres.V2[z], label = dt$labels[z], alpha = dt$alphas[z], size=font_size,
fontface = font_weight, hjust=1, colour=font_colour)}) +
coord_cartesian(xlim = c(-2,3), ylim =c(-1, (num_layers+4) )) +
theme_void() +
#theme_classic() + # gets rid of the ugly bounding box
theme( plot.background = element_rect(fill = background_color)
,axis.line = element_blank(), axis.ticks = element_blank(), axis.title = element_blank(), axis.text = element_blank()
#,plot.margin = element_blank()
,panel.grid = element_blank()
,panel.grid.major = element_blank()
,panel.grid.minor = element_blank()
,panel.background = element_rect(fill=NA)
,panel.border = element_rect(fill=NA)
,validate=TRUE) # sets the background and removes the various axes
option_markers <- c(rep(0,num_layers))
option_markers[highlight_layers] <- 1
suffix <- paste0(option_markers,collapse = "_")
if(save_path != ""){
ggsave(paste0(save_path,"\\pic",suffix,".png"), myplot, height=base_image_height*scaling_factor, width=base_image_width*scaling_factor, units = "cm")
} else {
myplot
}
return(myplot)
}
highlight_layers = "all"
num_layers <- 5
overwrite_layer_labels <- c('DATA','MAPPING','SCALES','STATISTICS','GEOMETRIES','FACETS','COORDINATES','THEMES')
overwrite_colours <- c('grey','blue','red','orange','paleturquoise','palegreen','palevioletred','midnightblue')
Ans the various example function calls produce:
generate_layer_diagram()
generate_layer_diagram(c(1:3),num_layers = num_layers)
generate_layer_diagram(1)
generate_layer_diagram(2)
# Data Mapping and Geometries
generate_layer_diagram(c(1,2,5))
which produces:
Thanks to #AllenCameron's excellent answer for the inspiration of passing a vector to highlight multiple layers at once.
I am trying to reproduce this kind of Figure, with two densities, a first one pointing upwards and a second one pointing downwards. I would also like to have some blank space between the two densities.
Here is the code I am currently using.
library(hrbrthemes)
library(tidyverse)
library(RWiener)
# generating data
df <- rwiener(n = 1e2, alpha = 2, tau = 0.3, beta = 0.5, delta = 0.5)
df %>%
ggplot(aes(x = q) ) +
geom_density(
data = . %>% filter(resp == "upper"),
aes(y = ..density..),
colour = "steelblue", fill = "steelblue",
outline.type = "upper", alpha = 0.8, adjust = 1, trim = TRUE
) +
geom_density(
data = . %>% filter(resp == "lower"),
aes(y = -..density..), colour = "orangered", fill = "orangered",
outline.type = "upper", alpha = 0.8, adjust = 1, trim = TRUE
) +
# stimulus onset
geom_vline(xintercept = 0, lty = 1, col = "grey") +
annotate(
geom = "text",
x = 0, y = 0,
# hjust = 0,
vjust = -1,
size = 3, angle = 90,
label = "stimulus onset"
) +
# aesthetics
theme_ipsum_rc(base_size = 12) +
theme(axis.text.y = element_blank() ) +
labs(x = "Reaction time (in seconds)", y = "") +
xlim(0, NA)
Which results in something like...
How could I add some vertical space between the two densities to reproduce the above Figure?
If you want to try without faceting, you're probably best to just plot the densities as polygons with adjusted y values according to your desired spacing:
s <- 0.25 # set to change size of the space
ud <- density(df$q[df$resp == "upper"])
ld <- density(df$q[df$resp == "lower"])
x <- c(ud$x[1], ud$x, ud$x[length(ud$x)],
ld$x[1], ld$x, ld$x[length(ld$x)])
y <- c(s, ud$y + s, s, -s, -ld$y - s, -s)
df2 <- data.frame(x = x, y = y,
resp = rep(c("upper", "lower"), each = length(ud$x) + 2))
df2 %>%
ggplot(aes(x = x, y = y, fill = resp, color = resp) ) +
geom_polygon(alpha = 0.8) +
scale_fill_manual(values = c("steelblue", "orangered")) +
scale_color_manual(values = c("steelblue", "orangered"), guide = guide_none()) +
geom_vline(xintercept = 0, lty = 1, col = "grey") +
annotate(
geom = "text",
x = 0, y = 0,
# hjust = 0,
vjust = -1,
size = 3, angle = 90,
label = "stimulus onset"
) +
# aesthetics
theme_ipsum_rc(base_size = 12) +
theme(axis.text.y = element_blank() ) +
labs(x = "Reaction time (in seconds)", y = "")
you can try facetting
set.seed(123)
q=rbeta(100, 0.25, 1)
df_dens =data.frame(gr=1,
x=density(df$q)$x,
y=density(df$q)$y)
df_dens <- rbind(df_dens,
data.frame(gr=2,
x=density(df$q)$x,
y=-density(df$q)$y))
ggplot(df_dens, aes(x, y, fill = factor(gr))) +
scale_x_continuous(limits = c(0,1)) +
geom_area(show.legend = F) +
facet_wrap(~gr, nrow = 2, scales = "free_y") +
theme_minimal() +
theme(strip.background = element_blank(),
strip.text.x = element_blank(),
axis.text.y = element_blank(),
axis.title.y = element_blank())
The space between both plots can be increased using panel.spacing = unit(20, "mm"). Instead of facet_grid you can also try facet_grid(gr~., scales = "free_y")
I'm trying to plot a network with ggraph and I'd like to add a circle around the graph, with the edges and nodes lying centered inside the circle.
Drawing the circle works just fine with the following code (adapted from Draw a circle with ggplot2)
gg_circle <- function(r, xc, yc, color = "black", fill = NA, lty = NA, size = NA, ...) {
x <- xc + r*cos(seq(0, pi, length.out = 100))
ymax <- yc + r*sin(seq(0, pi, length.out = 100))
ymin <- yc + r*sin(seq(0, -pi, length.out = 100))
annotate("ribbon", x = x, ymin = ymin, ymax = ymax,
color = color, fill = fill, lty = lty, size = size, ...)
}
But I can't manage to match the position of the network layer(s) with the position of the circle, which results in both nodes and edges lying partially outside the circle:
That's the crucial part of the code as it is right now (using highschool from ggraph as an example dataset for reproducibility purposes):
library(ggraph)
library(igraph)
graph <- graph_from_data_frame(highschool)
ggraph(graph, layout = "fr") +
geom_edge_link() +
geom_node_point() +
geom_node_text(aes(label = name),
check_overlap = TRUE, repel = TRUE,
nudge_x = 0.1, nudge_y = 0.1) +
gg_circle(r = 11, xc = 0, yc = 0, lty = 1, size = 0.2) +
theme(axis.ticks.length = unit(0, "cm"),
legend.position = "none",
plot.margin = unit(c(0, 0, 0, 0), "cm"),
panel.spacing = unit(c(0, 0, 0, 0), "cm")) +
coord_fixed()
Any ideas or suggestions on how to fix this? Thanks in advance!
I would try to use the node positions to find acceptable values for r, xc, and yc.
Step 1. Create plot (without the circle):
set.seed(9) # for reproducibility
p <- ggraph(graph, layout = "fr") +
geom_edge_link() +
geom_node_point() +
geom_node_text(aes(label = name),
check_overlap = TRUE,
repel = TRUE,
nudge_x = 0.1,
nudge_y = 0.1) +
theme(axis.ticks.length = unit(0, "cm"),
legend.position = "none",
plot.margin = unit(c(0, 0, 0, 0), "cm"),
panel.spacing = unit(c(0, 0, 0, 0), "cm")) +
coord_fixed()
Step 2. Get data from the plot's geom_node_point() layer (the 2nd layer in this case). Modify the gg_circle code to take this dataframe as input, & calculate the appropriate circle centre coordinates / radius:
p.positions <- layer_data(p, i = 2L)
gg_circle_from_position <- function(data,
color = "black", fill = NA,
lty = NA, size = NA, ...){
coord.x <- data[, 'x']
coord.y <- data[, 'y']
xc = mean(range(coord.x))
yc = mean(range(coord.y))
r = max(sqrt((coord.x - xc)^2 + (coord.y - yc)^2)) * 1.05
# expand radius by 5% so that no node sits exactly on the line;
# increase from 1.05 to some larger number if more buffer is desired.
# no change to this part
x <- xc + r*cos(seq(0, pi, length.out = 100))
ymax <- yc + r*sin(seq(0, pi, length.out = 100))
ymin <- yc + r*sin(seq(0, -pi, length.out = 100))
annotate("ribbon", x = x, ymin = ymin, ymax = ymax,
color = color, fill = fill, lty = lty, size = size, ...)
}
Step 3. Add circle to plot:
p + gg_circle_from_position(data = p.positions, lty = 1, size = 0.2)
I am trying to add the below "graphic" to a chart I am doing in R.
I could easily do the graphic in a graphics application and then 'glue' it together with the R graph. However, it could be cool to make everything in R since it has the caveat that the position of the black arrow depends on calculated number. In the below case 6.8.
Any suggestions on how I could trick R to produce something like this?
This is a start for a function in base graphics:
draw <- function(x){
plot(NA, xlim=c(0,7), ylim=c(-.3,1), xaxt="n", yaxt="n", xlab="", ylab="")
lines(x=c(0,0,1,1,2,2,3,3,4,4,5,5,6,6,7,7,0),
y=rep(c(0,1,1,0,0,1,1,0,0,1,1,0,0,1,1,0,0)))
lines(c(0,7),c(1,1))
for(i in 1:7) text(x = i-0.5, y= 0.5, labels=i)
arrows(0, 1.5, 7, 1.5, code=3)
polygon(x -1 +c(-.1, 0, .1),c(-.3,-0.05,-.3), col="black")
}
draw(4)
draw(3)
If you are interested in a base graphics function, you will probably want to make the width:heigth ratio fixed an change my polygon-triangle into a proper arrow, add some more text and things, but this should get you started:
Here's the ggplot2 solution:
df_nums <- data.frame(number <- 1:7,
fill <- c(rep("white", 5), "darkblue", "white"),
color <- c(rep("black", 5), "white", "black"))
df_text <- data.frame(label = c("Lower Risk", "Higher Risk", "Typically Lower Rewards",
"Typically Higher Rewards"),
hjust = c(0, 1, 0, 1),
x = c(0, 7, 0, 7),
y = c(2.9, 2.9, 2.1, 2.1))
arrow_x_pos <- 6.8 # position of arrow
p1 <- ggplot(df_nums) +
geom_tile(aes(x = number - .5, y = 1, fill = fill), size = 1, color = "black") +
geom_text(aes(x = number - .5, y = 1, color = color, label = number), size = 8) +
scale_color_identity(guide = "none") + scale_fill_identity(guide = "none") +
geom_text(data = df_text, aes(x = x, y = y, label = label, hjust = hjust), size = 5.5,
fontface = "bold") +
geom_text(aes(label = "Risk and Reward Profile", x = 0, y = 3.5),
fontface = "bold", size = 6.5, hjust = 0) +
geom_segment(x = 0, xend = 7, y = 2.5, yend = 2.5, size = 1,
arrow = arrow(length = unit(10,"pt"), ends = "both"),
color = "grey70") +
geom_segment(x = arrow_x_pos - 1, xend = arrow_x_pos - 1, y = -.3, yend = .2, size = 4,
arrow = arrow(length = unit(7, "pt"), type = "closed"),
lineend = "butt", linejoin = "mitre") +
ylim(-.2, 3.6) +
coord_fixed() +
theme_void()
p1
I'd like to add colors to certain words in titles to my graphs. I've been able to find some precedent here. Specifically, I'd like the text that's wrapped in apostrophes (in the output, below) to correspond to the color of their respective bar charts.
Here's how far I've gotten with titles in R before having to export a PDF to Adobe Illustrator or other program.
name <- c("Peter", "Gabriel", "Rachel", "Bradley")
age <- c(34, 13, 28, 0.9)
fake_graph <- family[order(family$age, decreasing = F), ]
fake_graph <- within(fake_graph, {
bar_color = ifelse(fake_graph$name == "Rachel", "blue", "gray")
})
# Plot creation
library(ggplot2)
fake_bar_charts <- ggplot() +
geom_bar(
data = fake_graph,
position = "identity",
stat = "identity",
width = 0.75,
fill = fake_graph$bar_color,
aes(x = name, y = age)
) +
scale_x_discrete(limits = fake_graph$name) +
scale_y_continuous(expand = c(0, 0)) +
coord_flip() +
theme_minimal()
family <- data.frame(name, age)
# Add title
library(grid)
library(gridExtra)
grid_title <- textGrob(
label = "I spend more time with 'Rachel' than\nwith 'other family members.'",
x = unit(0.2, "lines"),
y = unit(0.1, "lines"),
hjust = 0, vjust = 0,
gp = gpar(fontsize = 14, fontface = "bold")
)
gg <- arrangeGrob(fake_bar_charts, top = grid_title)
grid.arrange(gg)
Output:
This example uses ggplot2 to create bar charts as well as grid and gridExtra for the title functionality, but I'd be willing to work with any solution (preferably with ggplot2 to create the graph itself) that could provide me with the text in quotes to match their respective bar chart colors.
Any other solutions on this site haven't been able to solve this puzzle, but I would love to find a solution for this from within R.
Thank you for any help!
I wrote the label with too honest way. First grob's width decides second grob's x, and so on. I used grobTree() to group them. Because gTree doesn't have own size information, I gave arrangeGrob() an argument padding to keep gTree's space.
library(grid); library(gridExtra); library(ggplot2)
df <- data.frame(name = c("Rachel", "Peter", "Gabriel","Bradley"), age = c(23, 35, 12, 3))
fake_bar_charts <- ggplot(df, aes(x=name, y=age)) +
geom_bar(stat="identity", fill = c(rep("gray50",3), "red")) + coord_flip()
grobs <- grobTree(
gp = gpar(fontsize = 14, fontface = "bold"),
textGrob(label = "I spend more time with '", name = "title1",
x = unit(0.2, "lines"), y = unit(1.4, "lines"),
hjust = 0, vjust = 0),
textGrob(label = "Rachel", name = "title2",
x = grobWidth("title1") + unit(0.2, "lines"), y = unit(1.4, "lines"),
hjust = 0, vjust = 0, gp = gpar(col = "red")),
textGrob(label = "' than", name = "title3",
x = grobWidth("title1") + grobWidth("title2") + unit(0.2, "lines"), y = unit(1.4, "lines"),
hjust = 0, vjust = 0),
textGrob(label = "with '", name = "title4",
x = unit(0.2, "lines"), y = unit(0.1, "lines"),
hjust = 0, vjust = 0),
textGrob(label = "other family members", name = "title5",
x = grobWidth("title4") + unit(0.2, "lines"), y = unit(0.1, "lines"),
hjust = 0, vjust = 0, gp = gpar(col = "gray50")),
textGrob(label = "'.", name = "title6",
x = grobWidth("title4") + grobWidth("title5") + unit(0.2, "lines"), y = unit(0.1, "lines"),
hjust = 0, vjust = 0)
)
gg <- arrangeGrob(fake_bar_charts, top=grobs, padding = unit(2.6, "line"))
grid.newpage()
grid.draw(gg)
A very easy way is to use ggtext
Which is achieved with
library(ggtext) #remotes::install_github("wilkelab/ggtext")
ggplot(iris, aes(Sepal.Length, Sepal.Width, color = Species)) +
geom_point(size = 3) +
scale_color_manual(
name = NULL,
values = c(setosa = "#0072B2", virginica = "#009E73", versicolor = "#D55E00"),
labels = c(
setosa = "<i style='color:#0072B2'>I. setosa</i>",
virginica = "<i style='color:#009E73'>I. virginica</i>",
versicolor = "<i style='color:#D55E00'>I. versicolor</i>")
) +
labs(
title = "**Fisher's *Iris* dataset**
<span style='font-size:11pt'>Sepal width vs. sepal length for
<span style='color:#0072B2;'>setosa</span>,
<span style='color:#D55E00;'>versicolor</span>, and
<span style='color:#009E73;'>virginica</span>
</span>",
x = "Sepal length (cm)", y = "Sepal width (cm)"
) +
theme_minimal() +
theme(
plot.title = element_markdown(lineheight = 1.1),
legend.text = element_markdown(size = 11)
)
Here's a first attempt that draws on this answer about how to insert annotations outside of the plot area. The basic idea is to layer on custom text geoms with different colors. I don't find this answer very satisfactory, because (i) the edges of the characters are jagged (the result of overlaying the text on itself multiple times), and (ii) the location of the title needs to be manually specified, but it's a start:
library(ggplot2)
library(grid)
# Convenience function to make text
tt <- function(text, colour, x, y) {
annotation_custom(
grob = textGrob(
label = text, hjust = 0, gp = gpar(col = colour)),
xmin = x, xmax = x,
ymin = y, ymax = y
)
}
p <- ggplot(mpg, aes(x = class, fill = ifelse(class == "pickup", "a", "b"))) +
geom_bar() +
scale_fill_manual(guide = FALSE, values = c("blue", "grey")) +
coord_flip() +
theme(plot.margin = unit(c(4, 3, 3, 2), units = "lines"))
p <- p +
tt("I spend more time with 'pickup' than\nwith 'other family members.'",
"grey", 8.5, 0) +
tt("I spend more time with 'pickup' than\nwith",
"black", 8.5, 0) +
tt("I spend more time with 'pickup'\n",
"blue", 8.5, 0) +
tt("I spend more time with\n",
"black", 8.5, 0)
# Code to override clipping
gt <- ggplot_gtable(ggplot_build(p))
gt$layout$clip[gt$layout$name == "panel"] <- "off"
grid.draw(gt)
Using ggcharts and mdthemes this can be achieved quite easily.
name <- c("Peter", "Gabriel", "Rachel", "Bradley")
age <- c(34, 13, 28, 0.9)
family <- data.frame(name, age, stringsAsFactors = FALSE)
title <- paste(
"**I spend more time with '<span style=color:'#1F77B4'>Rachel</span>' than",
"with '<span style=color:'lightgray'>other family members</span>'**",
sep = "<br>"
)
ggcharts::bar_chart(family, name, age, highlight = "Rachel", bar_color = "#1F77B4") +
ggtitle(title) +
mdthemes::md_theme_minimal()
The bar_chart() function from ggcharts creates a horizontal, sorted bar chart by default. Highlighting is built-in with the highlight parameter.
The mdthemes package offers themes that render text as markdown/HTML. Note the ** aroung the title which makes it bold and the <span> tags with CSS to color the words.