Multicolored title with R - r

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.

Related

Modify the size of each legend icon in ggplot2

I am using ggplot/usmap libararies to plot highly skewed data onto a map.
Because the data is so skewed, I created uneven interval brackets. See below;
My Code:
library(dplyr)
library(tidyverse)
library(usmap)
library(ggplot2)
library(readxl)
library(rgdal)
plot_usmap(regions = "states",
# fill = 'orange',
labels = TRUE) +
geom_point(data = grant_sh,
size = 5,
aes(x = x,
y = y,
color = funding_cat)) +
theme(
legend.title = element_text(size = 16),
#change legend title font size
legend.text = element_text(size = 14),
#change legend text font size
legend.position = 'left',
plot.title = element_text(size = 22),
plot.subtitle = element_text(size = 16)
) + #+
scale_color_manual(
values = c('#D4148C', # pink muesaum
'#049CFC', #library,blue
'#1C8474',
'#7703fC'),
name = "Map Key",
labels = c(
'$1,500 - $4,000 (n = 7)',
'$4,001 - $6,000 (n = 12)',
'$6,001 - $20,000 (n = 6)',
'$20,001 - $40,000 (n = 25)'
)
) +
guides(colour = guide_legend(override.aes = list(size = 3)))
Current Output
Desired Output
I would like to adjust the legend key to reflect the size of each interval. So, for example 1500-400 would be the smallest icon, and 20,001-40,000 would be the largest.
I want to do this so that the viewer immediately knows that the intervals are not even. Any solution to achieve this outcome is greatly appreciated!
See how the sign/oval next to each interval represents the range of the interval in my example below.
One option to create this kind of legend would be to make it as a second plot and glue it to the main plot using e.g. patchwork.
Note: Especially with a map as the main plot and the export size if any, this approach requires some fiddling to position the legend, e.g. in my code below a added a helper row to the patchwork design to shift the legend upwards.
UPDATE: Update the code to include the counts in the labels. Added a second approach to make the legend using geom_col and a separate dataframe.
library(dplyr, warn = FALSE)
library(usmap)
library(ggplot2)
library(patchwork)
# Make example data
set.seed(123)
cat1 <- c(1500, 4001, 6001, 20001)
cat2 <- c(4000, 6000, 2000, 40000)
n = c(7, 12, 6, 25)
funding_cat <- paste0("$", cat1, " - $", cat2, " (n=", n, ")")
funding_cat <- factor(funding_cat, levels = rev(funding_cat))
grant_sh <- utils::read.csv(system.file("extdata", "us_states_centroids.csv", package = "usmapdata"))
grant_sh$funding_cat = sample(funding_cat, 51, replace = TRUE, prob = n / sum(n))
# Make legend plot
grant_sh_legend <- data.frame(
funding_cat = funding_cat,
n = c(7, 12, 6, 25)
)
legend <- ggplot(grant_sh, aes(y = funding_cat, fill = funding_cat)) +
geom_bar(width = .6) +
scale_y_discrete(position = "right") +
scale_fill_manual(
values = c('#D4148C',
'#049CFC',
'#1C8474',
'#7703fC')
) +
theme_void() +
theme(axis.text.y = element_text(hjust = 0),
plot.title = element_text(size = rel(1))) +
guides(fill = "none") +
labs(title = "Map Key")
map <- plot_usmap(regions = "states",
labels = TRUE) +
geom_point(data = grant_sh,
size = 5,
aes(x = x,
y = y,
color = funding_cat)) +
theme(
legend.position = 'none',
plot.title = element_text(size = 22),
plot.subtitle = element_text(size = 16)
) + #+
scale_color_manual(
values = c('#D4148C', # pink muesaum
'#049CFC', #library,blue
'#1C8474',
'#7703fC'),
name = "Map Key",
labels = c(
'$1,500 - $4,000 (n = 7)',
'$4,001 - $6,000 (n = 12)',
'$6,001 - $20,000 (n = 6)',
'$20,001 - $40,000 (n = 25)'
)
) +
guides(colour = guide_legend(override.aes = list(size = 3)))
# Glue together
design <- "
#B
AB
#B
"
legend + map + plot_layout(design = design, heights = c(5, 1, 1), widths = c(1, 10))
Using geom_bar the counts are computed from your dataset grant_sh. A second option would be to compute the counts manually or use a manually created dataframe and then use geom_col for the legend plot:
grant_sh_legend <- data.frame(
funding_cat = funding_cat,
n = c(7, 12, 6, 25)
)
legend <- ggplot(grant_sh, aes(y = funding_cat, n = n, fill = funding_cat)) +
geom_col(width = .6) +
scale_y_discrete(position = "right") +
scale_fill_manual(
values = c('#D4148C',
'#049CFC',
'#1C8474',
'#7703fC')
) +
theme_void() +
theme(axis.text.y = element_text(hjust = 0),
plot.title = element_text(size = rel(1))) +
guides(fill = "none") +
labs(title = "Map Key")

Complex Chart in R/ggplot with Proper Legend Display

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")))

Error: Invalid input: date_trans works with objects of class Date only when modifyin x axis

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.

Turning off ggplot clipping deletes line segment

I'm trying to draw some arrows in the margin of a ggplot. From what I've read, you have to turn off the plot clipping to do that. However, when I do that, it deletes a line segment I have on my graph.
library(ggplot2)
library(ggrepel)
library(grid)
#----------------- Fake data practice --------------------- #
mydata <- data.frame(Labels = letters[1:14],
X_Values = seq(1, 14, 1),
Y_Values = rnorm(14, mean = 0, sd = 1),
Influence = seq(1, 14, 1))
mydata$Influencer <- factor(ifelse(mydata$Influence <= 3, 1, 0))
# --- Get min/max from data and use to set range at -1to1 or -2to2
chartMax <- ifelse(min(mydata$Y_Values) < -1 | max(mydata$Y_Values) > 1, 2, 1)
chartMin <- ifelse(chartMax == 1, -1, -2)
yTitle = "Some Title"
# --- Label setting, if greater than 0 nudge up, else nudge down
mydata$Nudger <- ifelse(mydata$Y_Values >= 0, .1, -.1)
p <- ggplot(mydata, aes(x = X_Values, y = Y_Values, group = Influencer)) +
geom_point(aes(size = Influencer, color = Influencer), shape = 18) +
geom_segment(x = 0, xend = 14, y = 0, yend = 0, color = "red", linetype = "dashed", size = 1.2, alpha = .5) +
geom_text_repel(aes(x = X_Values, y = Y_Values, label = Labels),
box.padding = .4,
point.padding = .2,
nudge_y = .1) +
scale_color_manual(values = c("grey", "blue")) +
scale_size_manual(values = c(4, 6)) +
scale_y_continuous(name = "", limits = c(chartMin, chartMax)) +
scale_x_continuous(name = yTitle,
limits = c(1, 15),
breaks = c(2,13),
labels = c("Lower", "Higher")) +
theme_classic() + theme(plot.margin = unit(c(1,3,1,2), "lines"),
legend.position="none",
axis.ticks.x=element_blank(),
axis.text.x = element_text(face = "bold"),
axis.title = element_text(face = "bold"),
axis.line.x = element_line(color = "blue"
,size = 1
,arrow =
arrow(length = unit(0.5, "cm"),
ends = "both"))) +
annotation_custom(
grob = linesGrob(arrow=arrow(type="open", ends="both", length=unit(0.5, "cm")), gp=gpar(col="blue", lwd=2)),
xmin = -1.4, xmax = -1.4, ymin = chartMin, ymax = chartMax
)
p
# Here it works and you see the red dashed line
# Turn off panel clipping
gt <- ggplot_gtable(ggplot_build(p))
gt$layout$clip[gt$layout$name == "panel"] <- "off"
grid.draw(gt)
Ideally, I want a blue arrow that runs alongside the y-axis in the margins. I think I've got that, but I can't loose my dashed red line that runs along the inside the graph.
I can't explain why this is happening (seems like a bug, I suggest raising an issue here), but I can confirm that the issue is related to the line alpha. If we delete the alpha = 0.5 argument from geom_segment then the clipping=off works without deleting the line:

R how to add facet labels for pyramid like plot in ggplot2

I have created pyramid like plot and I want to add labels for each side of the plot (something like facet labels).
My data:
dt <- data.frame(Answer = factor(x = rep(x = c(1:3), times = 2),
labels = c("Yes", "No", "Maybe")),
Gender = factor(x = rep(x = c(1:2), each = 3),
labels = c("Female", "Male")),
Prc = c(74.4, 25.0, 0.6, 61.3, 35.5, 3.2),
label = c("74.4%", "25.0%", "0.6%", "61.3%", "35.5%", "3.2%"))
My plot:
My code for plot generation:
xmi <- -70
xma <- 80
library(ggplot2)
ggplot(data = dt, aes(x = Answer, fill = Gender)) +
geom_bar(stat = "identity", subset = .(Gender == "Female"), aes(y = Prc)) +
geom_text(subset = .(Gender == "Female"), aes(y = Prc, label = label), size = 4, hjust = -0.1) +
geom_bar(stat = "identity", subset = .(Gender == "Male"), aes(y=Prc * (-1)) ) +
geom_text(subset = .(Gender == "Male"), aes(y = Prc * (-1), label = label), size = 4, hjust = 1) +
scale_y_continuous(limits = c(xmi, xma), breaks=seq(xmi, xma,10),labels=abs(seq(xmi, xma,10))) +
theme(axis.text = element_text(colour = "black"),
plot.title = element_text(lineheight=.8) ) +
coord_flip() +
annotate("text", x = 3.3, y = -50, label = "Male", fontfacet = "bold") +
annotate("text", x = 3.3, y = 50, label = "Female", fontfacet = "bold") +
ylab("") + xlab("") + guides(fill=FALSE)
rm(xmi, xma)
And the facet labels labels example:
And the question is:
1. How to add facet labels to the pyramid like plot;
OR
2. Maybe there are the better way to make pyramid like plots.
A few possibilities. The first two construct a strip (i.e., facet labels) from scratch. The two differ in the way they position the strip grob. The third is a pyramid plot, similar to the one constructed here, but with a little more tidying up.
library(ggplot2)
dt <- data.frame(Answer = factor(x = rep(x = c(1:3), times = 2),
labels = c("Yes", "No", "Maybe")),
Gender = factor(x = rep(x = c(1:2), each = 3),
labels = c("Female", "Male")),
Prc = c(74.4, 25.0, 0.6, 61.3, 35.5, 3.2),
label = c("74.4%", "25.0%", "0.6%", "61.3%", "35.5%", "3.2%"))
xmi <- -100
xma <- 100
p = ggplot(data = dt, aes(x = Answer, fill = Gender)) +
geom_bar(stat = "identity", data = subset(dt, Gender == "Female"), aes(y = Prc)) +
geom_text(data = subset(dt, Gender == "Female"), aes(y = Prc, label = label),
size = 4, hjust = -0.1) +
geom_bar(stat = "identity", data = subset(dt, Gender == "Male"), aes(y=Prc * (-1)) ) +
geom_text(data = subset(dt, Gender == "Male"), aes(y = Prc * (-1), label = label),
size = 4, hjust = 1.1) +
scale_y_continuous(limits = c(xmi, xma), breaks = seq(xmi, xma, 10), labels = abs(seq(xmi, xma, 10))) +
theme(axis.text = element_text(colour = "black")) +
coord_flip() +
ylab("") + xlab("") + guides(fill = FALSE) +
theme(plot.margin = unit(c(2, 1, 1, 1), "lines"))
## Method 1
# Construct the strip
library(grid)
strip = gTree(name = "Strip",
children = gList(
rectGrob(gp = gpar(col = NA, fill = "grey85")),
textGrob("Female", x = .75, gp = gpar(fontsize = 8.8, col = "grey10")),
textGrob("Male", x = .25, gp = gpar(fontsize = 8.8, col = "grey10")),
linesGrob(x = .5, gp = gpar(col = "grey95"))))
# Position strip using annotation_custom
p1 = p + annotation_custom(strip, xmin = Inf, xmax = 3.75, ymax = Inf, ymin = -Inf)
g = ggplotGrob(p1)
# The strip is positioned outside the panel,
# therefore turn off clipping to the panel.
g$layout[g$layout$name=='panel', "clip"] = "off"
# Draw it
grid.newpage()
grid.draw(g)
## Method 2
# Construct the strip
# Note the viewport; in particular its position and justification
library(gtable)
fontsize = 8.8
gp = gpar(fontsize = fontsize, col = "grey10")
textGrobF = textGrob("Female", x = .75, gp = gp)
textGrobM = textGrob("Male", x = .25, gp = gp)
strip = gTree(name = "Strip",
vp = viewport(y = 1, just = "bottom", height = unit(2.5, "grobheight", textGrobF)),
children = gList(
rectGrob(gp = gpar(col = NA, fill = "grey85")),
textGrobF,
textGrobM,
linesGrob(x = .5, gp = gpar(col = "grey95"))))
g = ggplotGrob(p)
# Position strip using the gtable function, gtable_add_grob
# Strip is positioned in the plot panel,
# but because of the justification of strip's viewport,
# the strip is drawn outside the panel
# First, get the panel's position in the layout
pos = g$layout[grepl("panel", g$layout$name), c("t","l")]
g = gtable_add_grob(g, strip, t = pos$t, l = pos$l, clip = "off")
grid.newpage()
grid.draw(g)
## Method 3
# Pyramid plot
library(ggplot2)
library(scales)
library(stringr)
library(gtable)
library(grid)
df = dt
# Common theme
theme = theme(panel.grid.minor = element_blank(),
panel.grid.major = element_blank(),
axis.text.y = element_blank(),
axis.title.y = element_blank(),
plot.title = element_text(size = 10, hjust=0.5))
#### 1. "male" plot - to appear on the right
ggM <- ggplot(data = subset(df, Gender == 'Male'), aes(x = Answer)) +
geom_bar(aes(y = .01*Prc), stat = "identity", fill = "skyblue", width = .5) +
geom_text(data = subset(dt, Gender == "Male"), aes(y = .01*Prc, label = label), hjust = -.1, size = 4) +
scale_y_continuous('', limits = c(0, 1), expand = c(0, 0), labels = percent) +
labs(x = NULL) +
ggtitle("Male") +
coord_flip() + theme +
theme(plot.margin= unit(c(1, 1, 0, 0), "lines"))
# get ggplot grob
gtM <- ggplotGrob(ggM)
#### 2. "female" plot - to appear on the left -
# reverse the 'Percent' axis using trans = "reverse"
ggF <- ggplot(data = subset(df, Gender == 'Female'), aes(x = Answer)) +
geom_bar(aes(y = .01*Prc), stat = "identity", fill = "salmon", width = .5) +
geom_text(data = subset(dt, Gender == "Female"), aes(y = .01*Prc, label = label), hjust = 1.1, size = 4) +
scale_y_continuous('', limits = c(1, 0), trans = "reverse", expand = c(0, 0), labels = percent) +
labs(x = NULL) +
ggtitle("Female") +
coord_flip() + theme +
theme(plot.margin= unit(c(1, 0, 0, 1), "lines"))
# get ggplot grob
gtF <- ggplotGrob(ggF)
## Swap the tick marks to the right side of the plot panel
# Get the row number of the left axis in the layout
rn <- which(gtF$layout$name == "axis-l")
# Extract the axis (tick marks and axis text)
axis.grob <- gtF$grobs[[rn]]
axisl <- axis.grob$children[[2]] # Two children - get the second
# axisl # Note: two grobs - text and tick marks
# Get the tick marks - NOTE: tick marks are second
yaxis = axisl$grobs[[2]]
yaxis$x = yaxis$x - unit(1, "npc") + unit(2.75, "pt") # Reverse them
# Add them to the right side of the panel
# Add a column to the gtable
gtF <- gtable_add_cols(gtF, gtF$widths[3], length(gtF$widths) - 1)
# Add the grob
pos = gtF$layout[grepl("panel", gtF$layout$name), "t"]
gtF <- gtable_add_grob(gtF, yaxis, t = pos, length(gtF$widths) - 1)
# Remove original left axis
gtF = gtF[,-c(2,3)]
#### 3. Answer labels - create a plot using geom_text - to appear down the middle
fontsize = 3
ggC <- ggplot(data = subset(df, Gender == 'Male'), aes(x=Answer)) +
geom_bar(stat = "identity", aes(y = 0)) +
geom_text(aes(y = 0, label = Answer), size = fontsize) +
ggtitle("Answer") +
coord_flip() + theme_bw() + theme +
theme(panel.border = element_rect(colour = NA))
# get ggplot grob
gtC <- ggplotGrob(ggC)
# Get the title
Title = gtC$grobs[[which(gtC$layout$name == "title")]]
# Get the plot panel
gtC = gtC$grobs[[which(gtC$layout$name == "panel")]]
#### 4. Arrange the components
## First, combine "female" and "male" plots
gt = cbind(gtF, gtM, size = "first")
## Second, add the labels (gtC) down the middle
# Add column to gtable
maxlab = df$Answer[which(str_length(df$Answer) == max(str_length(df$Answer)))]
gt = gtable_add_cols(gt, sum(unit(1, "grobwidth", textGrob(maxlab, gp = gpar(fontsize = fontsize*72.27/25.4))), unit(5, "mm")),
pos = length(gtF$widths))
# Add the Answer grob
gt = gtable_add_grob(gt, gtC, t = pos, l = length(gtF$widths) + 1)
# Add the title; ie the label 'Answer'
gt = gtable_add_grob(gt, Title, t = 3, l = length(gtF$widths) + 1)
### 5. Draw the plot
grid.newpage()
grid.draw(gt)

Resources